C YXLIB Customisation Parameters
C ------------------------------
 
C Routine Names
C -------------
 
C Field Definitions: Parse Tree Attributes
C ----------------------------------------
C Note: The high-order bit in the word (bit 31 in a 32-bit machine) MUST
C       NOT BE USED, as ordinary arithmetic is used to extract some fields
 
C Attribute Table Macros
C ----------------------
 
C YXLIB Bits
C ----------
 
C YXLIB Local Record Macros
C -------------------------
C   type VARX = record
C                   su: integer;    (* Storage units for variable *)
C                   common: ^(S_COMMON) or -maxint..-1;
C                                   (* ^(common block symbol), nil (0) or
C                                      negative of equivalence class number *)
C                   comsize: integer;(* Offset in common or equiv class *)
C                   equiv: ^EQV;    (* Pointer to equivalence link *)
C                   if SYMBOL(var_arr_decl)<>0 then array: ARRAYX
C                                   (* array information stored here *)
C               end;
C
C   type ARRAYX = record
C                   elts: integer;  (* Number of elements in the array *)
C                   dims: integer;  (* Number of dimensions of the array *)
C                   limits: array [1..dims] of
C                               record LOWER,UPPER: integer end
C                 end;
 
 
C   type EQH = HEAD record          (* Equivalence head record *)
C                       common: ^(S_COMMON) or -maxint..-1;
C                       usage: set of usage_bits
C                   end;
 
C   type EQV = LINK record          (* Equivalence variable record (link) *)
C                       sudif: integer;
C                       symbol: ^(S_VAR)
C                   end;
 
C   type LPR = record
C                   glob: ^(GPU) or -^(GEX);
C                   nargs: integer;
C                   args: array [1..nargs] of packed record
C                               dtype: min_dtype..max_dtype;
C                               argument_type: atype;
C                               descendents: ^HEAD;
C                               if dtype=type_char then
C                                   min_length, max_length: integer
C                               end if
C                           end record
C              end;
 
C                                   (* Argument type definitions *)
C   type ATYPE = (scalar,arelm,array,proc,label);
C   const min_atype = scalar; max_atype = label;
 
C YXLIB Record Definition: Semi-Local
C -----------------------------------
C   type PAREC = LINK record
C                   argnum: integer; (* Argument number passed down as *)
C                   prsym: ^(S_PROC); (* Procedure passed down to *)
C                   argsym: ^symbol; (* Actual argument being passed down *)
C                   pusym: ^(S_PU); (* Associating program-unit (context) *)
C                   stmtno: integer; (* Statement number of assoc (context) *)
C                end;
 
C   type UNSAF = LINK record
C                   code: 1..5;     (* Type of unsafe reference to be checked *)
C                   argnum: integer;(* Argument number applicable *)
C                   extra: anything;(* Extra data (not used by inherit_expr) *)
C                   pusym: ^(S_PU); (* Context: associating program-unit *)
C                   stmtno: integer;(* Context: statement number *)
C                   prsym: ^(S_PROC)(* proc being called *)
C                end;
 
C YXLIB Global Record Macros
C --------------------------
C
C   type G_COM = record             Global common block record
C                   size: integer;
C                   type: (character,numeric,mixed); (* logical = numeric *)
C                   save: (saved,not_saved,only_in_main);
C                   init: integer   (* Number of times init'ed by block data *)
C                end;
 
C
C   type G_PU = record              Global program-unit record
C                   dtype: integer;
C                   chrlen: integer;
C                   culist: ^HEAD;  (* common block usage list header ptr *)
C                   nargs: integer;
C                   descend: ^HEAD; (* descendent routine list header ptr *)
C                   entrys: ^(HEAD) record ^G_ENT end;
C                   args: array [1..nargs] of gpuarg
C               end;
 
C   type G_ENT = record
C                   dtype: integer;
C                   chrlen: integer;
C                   pu: ^G_PU;
C                   nargs: integer;
C                   descend: ^HEAD; (* descendent routine list header ptr *)
C                   args: array [1..nargs] of ^guparg
C                end;
 
C type gpuarg = record
C                   dtype,chlen: integer;
C                   usage: (arg,read,update);
C                   struc: (scal,array,proc,label);
C                   size: integer;
C                   pass: ^HEAD;
C                   inh: ^HEAD(inherit)
C               end;
C type inherit = record
C                   type: (proc,expr,dupl,comm,sfa,doix,arg);
C                   ass: ^(GPU);    (* associating program-unit *)
C                   snum: integer;  (* statement number of association *)
C                   if (type=proc) then
C                       gsyptr: ^(GPU)/-^(GEX)
C                   else
C                       extra: integer (* unsafe ref extra data *)
C                   end if
 
 
C Global Descendant Routine Types
C -------------------------------
 
C Error Codes returned by YXLIB
C -----------------------------
C
C Additional definitions for ISTSA
C
 
 
 
 
 
 
 
 
C                                   parameter length
 
 
 
 
 
 
 
C ----------------------------------------------------------------------
C
C       A N A L Y S   -   Analyse the program stored in the parse tree
C
 
        SUBROUTINE ANALYS(TRACE,ERRORS,WARNS)
        LOGICAL TRACE
        INTEGER ERRORS,WARNS
 
        COMMON/ERRORC/NERROR,NWARN
        INTEGER NERROR,NWARN
 
        COMMON/CONTXT/PUN,STMTNO
        INTEGER PUN,STMTNO
 
        COMMON/PUNAMC/PUNAME
        CHARACTER*6 PUNAME
 
        INTEGER PTR,NMAINS
        LOGICAL MAIN
 
        SAVE /CONTXT/,/PUNAMC/,/ERRORC/
 
        INTEGER LENSTR
 
        INTEGER ZYROOT,ZYNEXT,ZYDOWN,ZYNTYP
        EXTERNAL ZYROOT,ZYNEXT,ZYDOWN,ZYNTYP,ZMESS
 
        PTR=ZYDOWN(ZYROOT())
        PUN=1
        NMAINS=0
        NERROR=ERRORS
        NWARN=WARNS
 
 100    MAIN=ZYNTYP(PTR).EQ.2
        IF (MAIN) NMAINS=NMAINS+1
        CALL PASS1(PTR,MAIN)
        PTR=ZYNEXT(PTR)
        PUN=PUN+1
        IF (TRACE)
     +      CALL ZMESS('['//PUNAME(:LENSTR(PUNAME))//' processed]',
     +                 1)
        IF (PTR.NE.0) GOTO 100
        IF (NERROR.EQ.0) THEN
            IF (NMAINS.GT.1)
     +          CALL ERRMES('More than one main program',-1)
            CALL PASS4
            IF (TRACE)
     +          CALL ZMESS('[Global processing completed]',1)
        ELSE IF (TRACE) THEN
            CALL ZMESS('[No global processing]',1)
        END IF
        ERRORS=NERROR
        WARNS=NWARN
 
        END
C ----------------------------------------------------------------------
C
C       P A S S 1   -   Process a single program-unit, pass 1
C
 
        SUBROUTINE PASS1(PUROOT,MAIN)
        INTEGER PUROOT
        LOGICAL MAIN
 
        INTEGER MAXNTY
        PARAMETER (MAXNTY=132)
 
        COMMON/ERRORC/NERROR,NWARN
        INTEGER NERROR,NWARN
 
        COMMON/CONTXT/PUN,STMTNO
        INTEGER PUN,STMTNO
 
        COMMON/PUNAMC/PUNAME
        CHARACTER*6 PUNAME
 
        COMMON/DOSTK/DOLVL,DOLBL,DOIDX
        INTEGER DOLVL,DOLBL(25),DOIDX(25)
 
        INTEGER PTR,NTYPE,P2,TEXT(134),SYMBOL(8),STATUS,I,
     +          SEQIN(MAXNTY),SEQOUT(MAXNTY),SEQ,TMP,LABEL,NTYPE2,
     +          ERRCNT,SAVSNO
        LOGICAL BLKDTA,SEQOK,LABLED
 
        SAVE /CONTXT/,/PUNAMC/,/DOSTK/,/ERRORC/,SEQIN,SEQOUT
 
        INTEGER ZYDOWN,ZYNEXT,ZYNTYP,ZYUP,CTOI,ZYXGVA
        EXTERNAL ZYDOWN,ZYNEXT,ZYNTYP,ZYUP,ZYGTSY,ZYGTST,ZITOF,CTOI,
     +           ZYXSVA,ZYXGVA,ZYXCEQ,ERRSYM
 
C Statement sequence processing:
C   SEQ = current position in sequence
C   SEQIN(node type) = maximum position at which this node type can occur
C   SEQOUT(node type) = minimum position implied by this node
C   SEQOK = statement sequence ok so far (so we only output the one error
C           message)
C
C   Sequence Position Numbers: 0 = P.U. header stmt (enforced by ISTYP)
C                              1 = FORMAT/ENTRY/PARAMETER/IMPLICIT
C                              2 = FORMAT/ENTRY/PARAMETER/other specs
C                              3 = FORMAT/ENTRY/DATA/statement functions
C                              4 = FORMAT/ENTRY/DATA/executables
C                              5 = END statement (enforced by ISTYP)
 
        DATA SEQIN(6),SEQOUT(6)/4,5/
        DATA SEQIN(7),SEQOUT(7)/0,1/
        DATA SEQIN(8),SEQOUT(8)/0,1/
        DATA SEQIN(16),SEQOUT(16)/0,1/
        DATA SEQIN(18),SEQOUT(18)/4,1/
        DATA SEQIN(19),SEQOUT(19)/0,1/
        DATA SEQIN(20),SEQOUT(20)/2,2/
        DATA SEQIN(24),SEQOUT(24)/2,2/
        DATA SEQIN(26),SEQOUT(26)/2,2/
        DATA SEQIN(30),SEQOUT(30)/2,2/
        DATA SEQIN(32),SEQOUT(32)/1,1/
        DATA SEQIN(35),SEQOUT(35)/2,1/
        DATA SEQIN(37),SEQOUT(37)/2,2/
        DATA SEQIN(38),SEQOUT(38)/2,2/
        DATA SEQIN(39),SEQOUT(39)/2,2/
        DATA SEQIN(41),SEQOUT(41)/4,3/
        DATA SEQIN(49),SEQOUT(49)/4,4/
        DATA SEQIN(50),SEQOUT(50)/4,4/
        DATA SEQIN(51),SEQOUT(51)/4,4/
        DATA SEQIN(52),SEQOUT(52)/4,4/
        DATA SEQIN(53),SEQOUT(53)/4,4/
        DATA SEQIN(55),SEQOUT(55)/4,4/
        DATA SEQIN(56),SEQOUT(56)/4,4/
        DATA SEQIN(57),SEQOUT(57)/4,4/
        DATA SEQIN(58),SEQOUT(58)/4,4/
        DATA SEQIN(59),SEQOUT(59)/4,4/
        DATA SEQIN(60),SEQOUT(60)/4,4/
        DATA SEQIN(61),SEQOUT(61)/4,4/
        DATA SEQIN(62),SEQOUT(62)/4,4/
        DATA SEQIN(63),SEQOUT(63)/4,4/
        DATA SEQIN(64),SEQOUT(64)/4,4/
        DATA SEQIN(65),SEQOUT(65)/4,4/
        DATA SEQIN(66),SEQOUT(66)/4,4/
        DATA SEQIN(67),SEQOUT(67)/4,4/
        DATA SEQIN(72),SEQOUT(72)/4,4/
        DATA SEQIN(73),SEQOUT(73)/4,4/
        DATA SEQIN(74),SEQOUT(74)/4,4/
        DATA SEQIN(75),SEQOUT(75)/4,4/
        DATA SEQIN(76),SEQOUT(76)/4,4/
        DATA SEQIN(77),SEQOUT(77)/4,4/
        DATA SEQIN(78),SEQOUT(78)/4,1/
        DATA SEQIN(82),SEQOUT(82)/4,4/
        DATA SEQIN(83),SEQOUT(83)/4,4/
        DATA SEQIN(121),SEQOUT(121)/3,3/
 
        BLKDTA=ZYNTYP(PUROOT).EQ.5
        STMTNO=1
        PTR=ZYDOWN(PUROOT)
        SEQOK=.TRUE.
        SEQ=0
        DOLVL=0
        IF (MAIN) PUNAME='$MAIN'
        ERRCNT=NERROR
 
  99    NTYPE=ZYNTYP(PTR)
        IF (NTYPE.EQ.8 .OR. NTYPE.EQ.16 .OR.
     +           NTYPE.EQ.7 .OR. NTYPE.EQ.19) THEN
            P2=ZYDOWN(PTR)
            IF (P2.NE.0) THEN
              IF (ZYNTYP(P2).NE.108) P2=ZYNEXT(P2)
              IF (P2.NE.0) THEN
                  CALL ZYGTSY(-ZYDOWN(P2),SYMBOL)
                  CALL ZYGTST(SYMBOL(2),TEXT)
                  CALL ZITOF(TEXT,1,6,PUNAME,.FALSE.)
              ENDIF
            ENDIF
        ENDIF
        IF (SEQIN(NTYPE).LT.SEQ .AND.SEQOK) THEN
            CALL ERRMES('Statement out of sequence',-1)
            SEQOK=.FALSE.
        END IF
        SEQ=MAX(SEQ,SEQOUT(NTYPE))
        PTR=ZYNEXT(PTR)
        STMTNO=STMTNO+1
        IF (PTR.NE.0) GOTO 99
        IF (NERROR.NE.ERRCNT) RETURN
 
        STMTNO=1
        SEQ=0
        PTR=ZYDOWN(PUROOT)
 
 100    NTYPE=ZYNTYP(PTR)
        IF (SEQ.LE.2 .AND. SEQOUT(NTYPE).GT.2 .AND. NERROR.EQ.ERRCNT)
     +  THEN
            SAVSNO=STMTNO
            STMTNO=0
            CALL PASS2(PUN,MAIN)
            IF (NERROR.EQ.ERRCNT) CALL PASS3(PUROOT,MAIN)
            STMTNO=SAVSNO
        END IF
        SEQ=MAX(SEQ,SEQOUT(NTYPE))
        P2=ZYDOWN(PTR)
        LABLED=.FALSE.
        IF (P2.NE.0) THEN
            IF (ZYNTYP(P2).EQ.115) THEN
                LABLED=.TRUE.
                CALL ZYGTSY(-ZYDOWN(P2),SYMBOL)
                IF (MOD(SYMBOL(6),1000).GT.0 .AND.
     +              (NTYPE.EQ.51 .OR. NTYPE.EQ.53 .OR.
     +              NTYPE.EQ.55 .OR. NTYPE.EQ.57 .OR.
     +              NTYPE.EQ.83 .OR. NTYPE.EQ.63 .OR.
     +              NTYPE.EQ.61 .OR. NTYPE.EQ.6))
     +              CALL ERRMES('Illegal ending statement for DO loop',
     +                          -1)
C If possible end-of-DO-loop, remember the label value
                IF (DOLVL.GT.0) THEN
                    CALL ZYGTST(SYMBOL(2),TEXT)
                    I=1
                    LABEL=CTOI(TEXT,I)
                END IF
                P2=ZYNEXT(P2)
            END IF
        END IF
        IF (NTYPE.EQ.49) THEN
            IF (BLKDTA) CALL ERRMES('Invalid statement in BLOCK DATA',
     +                              -1)
            CALL PROASG(P2)
        ELSE IF (NTYPE.EQ.61) THEN
            IF (BLKDTA) CALL ERRMES('Invalid statement in BLOCK DATA',
     +                              -1)
            CALL PRODO(P2)
        ELSE IF (NTYPE.EQ.57 .OR. NTYPE.EQ.58) THEN
            IF (BLKDTA) CALL ERRMES('Invalid statement in BLOCK DATA',
     +                              -1)
            CALL PROBIF(P2)
        ELSE IF (NTYPE.EQ.56) THEN
            IF (BLKDTA) CALL ERRMES('Invalid statement in BLOCK DATA',
     +                              -1)
            CALL PROLIF(P2)
C Always check out the conditional statement...
            PTR=ZYNEXT(P2)
            GOTO 100
        ELSE IF (NTYPE.EQ.67) THEN
            IF (BLKDTA) CALL ERRMES('Invalid statement in BLOCK DATA',
     +                              -1)
            CALL PROPRI(P2)
        ELSE IF (NTYPE.EQ.66) THEN
            IF (BLKDTA) CALL ERRMES('Invalid statement in BLOCK DATA',
     +                              -1)
            CALL PROREA(P2)
        ELSE IF (NTYPE.EQ.65) THEN
            IF (BLKDTA) CALL ERRMES('Invalid statement in BLOCK DATA',
     +                              -1)
            CALL PROWRI(P2)
        ELSE IF (NTYPE.EQ.72 .OR. NTYPE.EQ.73 .OR.
     +           NTYPE.EQ.74 .OR. NTYPE.EQ.77 .OR.
     +           NTYPE.EQ.75 .OR. NTYPE.EQ.76) THEN
            IF (BLKDTA) CALL ERRMES('Invalid statement in BLOCK DATA',
     +                              -1)
            CALL PROAUX(P2)
        ELSE IF (NTYPE.EQ.53) THEN
            IF (BLKDTA) CALL ERRMES('Invalid statement in BLOCK DATA',
     +                              -1)
            CALL PROGOA(P2)
        ELSE IF (NTYPE.EQ.52) THEN
            IF (BLKDTA) CALL ERRMES('Invalid statement in BLOCK DATA',
     +                              -1)
            CALL PROGOC(P2)
        ELSE IF (NTYPE.EQ.35) THEN
            CALL PROPAR(P2)
        ELSE IF (NTYPE.EQ.30 .OR. NTYPE.EQ.20) THEN
            CALL PROTYP(P2)
        ELSE IF (NTYPE.EQ.26) THEN
            CALL PROCOM(P2,BLKDTA)
        ELSE IF (NTYPE.EQ.41) THEN
            CALL PRODAT(P2,BLKDTA)
        ELSE IF (NTYPE.EQ.121) THEN
            IF (BLKDTA) CALL ERRMES('Invalid statement in BLOCK DATA',
     +                              -1)
            CALL PROSF(P2)
        ELSE IF (NTYPE.EQ.50) THEN
            IF (BLKDTA) CALL ERRMES('Invalid statement in BLOCK DATA',
     +                              -1)
            CALL PROASS(P2)
        ELSE IF (NTYPE.EQ.37 .OR. NTYPE.EQ.38) THEN
            IF (BLKDTA) CALL ERRMES('Invalid statement in BLOCK DATA',
     +                              -1)
        ELSE IF (NTYPE.EQ.82) THEN
            IF (BLKDTA) CALL ERRMES('Invalid statement in BLOCK DATA',
     +                              -1)
            CALL PROCAL(P2)
        ELSE IF (NTYPE.EQ.83) THEN
            IF (ZYNTYP(PUROOT).EQ.2) THEN
                CALL ERRMES('RETURN invalid in main program',-1)
            ELSE IF (BLKDTA) THEN
                CALL ERRMES('Invalid statement in BLOCK DATA',-1)
            ELSE
                CALL PRORET(P2)
            END IF
        ELSE IF (NTYPE.EQ.55) THEN
            IF (BLKDTA) CALL ERRMES('Invalid statement in BLOCK DATA',
     +                              -1)
            CALL PROAIF(P2)
        ELSE IF (NTYPE.EQ.63 .OR. NTYPE.EQ.64) THEN
            IF (BLKDTA) CALL ERRMES('Invalid statement in BLOCK DATA',
     +                              -1)
            CALL PROPAU(P2)
        ELSE IF (NTYPE.EQ.8 .OR. NTYPE.EQ.16 .OR.
     +           NTYPE.EQ.7 .OR. NTYPE.EQ.19) THEN
            IF (P2.NE.0) THEN
                NTYPE2=ZYNTYP(P2)
                IF (NTYPE2.NE.108) THEN
                    TMP=ZYDOWN(P2)
                    IF (TMP.NE.0) THEN
                        IF (ZYNTYP(TMP).EQ.17) THEN
                            CALL ZYXSVA(TMP,0)
                        ELSE
                            STATUS=-2
                            CALL EXPR(TMP,.TRUE.,0,STATUS)
                            IF (STATUS.EQ.-2)
     +                          CALL CHKTYP(NTYPE2,ZYXGVA(TMP))
                        END IF
                    END IF
                    P2=ZYNEXT(P2)
                    IF (ZYNTYP(P2).NE.108)
     +                  CALL ERRMES('PASS1: CORRUPT TREE',-1001)
                END IF
                IF (NTYPE.EQ.8 .OR. NTYPE.EQ.16)
     +              CALL PROSUB(P2)
            ELSE IF (NTYPE.EQ.19) THEN
                PUNAME='$BLOCK'
            ELSE
                CALL ERRMES('PROPU: IMPOSSIBLE ERROR',-1001)
            END IF
        ELSE IF (NTYPE.EQ.18) THEN
            IF (BLKDTA) CALL ERRMES('Invalid statement in BLOCK DATA',
     +                              -1)
            CALL PROSUB(P2)
        ELSE IF (NTYPE.EQ.39) THEN
            CALL PROSAV(P2,MAIN)
        ELSE IF (NTYPE.EQ.32) THEN
 150        TMP=ZYDOWN(P2)
            IF (ZYDOWN(TMP).NE.0) THEN
                STATUS=-2
                CALL EXPR(ZYDOWN(TMP),.TRUE.,0,STATUS)
                IF (STATUS.EQ.-2)
     +              CALL CHKTYP(ZYNTYP(TMP),ZYXGVA(ZYDOWN(TMP)))
            END IF
            P2=ZYNEXT(P2)
            IF (P2.NE.0) GOTO 150
        ELSE IF (NTYPE.EQ.78) THEN
            CALL PROFMT(P2)
        ELSE IF (NTYPE.NE.62 .AND. NTYPE.NE.6 .AND.
     +           NTYPE.NE.51 .AND. NTYPE.NE.59 .AND.
     +           NTYPE.NE.60 .AND. NTYPE.NE.24) THEN
            CALL ERRMES('Unknown statement type',-1)
        END IF
C Check for ending a DO loop
        IF (LABLED .AND. NTYPE.NE.61 .AND. DOLVL.GT.0) THEN
 200        IF (DOLBL(DOLVL).EQ.LABEL) THEN
                DOLVL=DOLVL-1
                IF (DOLVL.GT.0) GOTO 200
            END IF
        END IF
        P2=PTR
        PTR=ZYNEXT(PTR)
        STMTNO=STMTNO+1
        IF (PTR.NE.0) GOTO 100
C Check for the conditional statement part of a logical IF
        PTR=ZYUP(P2)
        IF (PTR.NE.PUROOT) THEN
            PTR=ZYNEXT(PTR)
            GOTO 100
        END IF
        STMTNO=0
        IF (NERROR.EQ.ERRCNT) CALL ZYXCEQ(ERRSYM)
 
        END
C ----------------------------------------------------------------------
C
C       P A S S 2   -   Process a single program unit, pass 2
C
 
        SUBROUTINE PASS2(PUN,MAIN)
        INTEGER PUN
        LOGICAL MAIN
 
        INTEGER COMSTK
        PARAMETER (COMSTK=20)
 
        INTEGER SYMPTR,SYMBOL(8),PUTYPE,COMPTR(COMSTK),COMSP,
     +          I,ARGLST(2),STATUS
 
        INTEGER ZYGNSW,LENGTH,ZIAND,ZYXSCM
        EXTERNAL ZYGNSW,LENGTH,ZYXSCM,ZYXSSU,ZIAND,
     +           ZYXSPA
 
        SYMPTR=0
        COMSP=0
        IF (ZYGNSW(SYMPTR,PUN,SYMBOL).EQ.-100)
     +      CALL ERRMES('No symbols in pu',-1001)
 
C Pass 2A: Push common block pointers onto a stack & scan it later
 
 100    IF (SYMBOL(1).EQ.1) THEN
            IF (SYMBOL(4).EQ.0) THEN
                CALL ERRSYM('Undefined label - ',SYMPTR,-1)
            ELSE IF (SYMBOL(7)+SYMBOL(5)+
     +               SYMBOL(6).EQ.0) THEN
                CALL ERRSYM('Unreferenced label - ',SYMPTR,-1002)
            END IF
        ELSE IF (SYMBOL(1).EQ.4) THEN
            PUTYPE=SYMBOL(4)
            IF (SYMBOL(8).EQ.0)
     +          CALL ZYXSPA(SYMPTR,0,ARGLST)
        ELSE IF (SYMBOL(1).EQ.9) THEN
            IF ((SYMBOL(4).EQ.6 .OR.
     +          PUTYPE.EQ.6) .AND. SYMBOL(4).NE.PUTYPE)
     +      THEN
                CALL ERRSYM('ENTRY type conflict with function - ',
     +                      SYMPTR,-1)
            END IF
        ELSE IF (SYMBOL(1).EQ.2) THEN
            IF (SYMBOL(4).EQ.0) THEN
                CALL ERRSYM('Common block SAVEd but does n'//'ot appe'//
     +                      'ar in a COMMON statement - ',SYMPTR,-1)
            ELSE
                COMSP=COMSP+1
                IF (COMSP.LE.COMSTK) COMPTR(COMSP)=SYMPTR
            END IF
        ELSE IF (SYMBOL(1).EQ.5) THEN
            CALL ZYXSSU(SYMPTR)
        END IF
        IF (ZYGNSW(SYMPTR,PUN,SYMBOL).NE.-100) GOTO 100
 
C Pass2B: Process the common block pointers
 
        DO 200 I=1,MIN(COMSP,COMSTK)
            STATUS=ZYXSCM(COMPTR(I),MAIN)
            IF (STATUS.EQ.-67) THEN
                CALL ERRSYM('Internal Error processing common block ',
     +                      COMPTR(I),-1001)
            ELSE IF (STATUS.EQ.-68) THEN
                CALL ERRSYM('Unused common block - ',COMPTR(I),-1002)
            ELSE IF (STATUS.NE.-2) THEN
                CALL ERRSYM(
     +'Unknown return from ZYXSCM for ',COMPTR(I),-1001)
            END IF
 200    CONTINUE
        IF (COMSP.GT.COMSTK) THEN
            SYMPTR=COMPTR(COMSTK)
            IF (ZYGNSW(SYMPTR,PUN,SYMBOL).EQ.-100)
     +          CALL ERRMES('PASS2: INTERNAL ERROR (COMMON BLOCKS)',
     +                      -1001)
 300        IF (SYMBOL(1).EQ.2) THEN
                STATUS=ZYXSCM(SYMPTR,MAIN)
                IF (STATUS.EQ.-67) THEN
                    CALL ERRSYM(
     +                  'Internal Error processing common block ',
     +                  SYMPTR,-1001)
                ELSE IF (STATUS.EQ.-68) THEN
                    CALL ERRSYM('Unused common block - ',SYMPTR,
     +                          -1002)
                ELSE IF (STATUS.NE.-2) THEN
                    CALL ERRSYM(
     +'Unknown return from ZYXSCM for ',SYMPTR,-1001)
                END IF
            END IF
            IF (ZYGNSW(SYMPTR,PUN,SYMBOL).EQ.-2) GOTO 300
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       P A S S 3   -   Process a single program unit, pass 3
C
 
        SUBROUTINE PASS3(PUROOT,MAIN)
        INTEGER PUROOT
        LOGICAL MAIN
 
        COMMON/CONTXT/PUN,STMTNO
        INTEGER PUN,STMTNO
 
        INTEGER PTR,SETPTR,ITMPTR,LASPTR,CURSUN,LASSUN,ITMSYM,LASSYM,
     +          SYMBOL(8),STATUS
 
        INTEGER GETSU
 
        INTEGER ZYDOWN,ZYNEXT,ZYNTYP,ZYXEQV
        EXTERNAL ZYDOWN,ZYNEXT,ZYNTYP,ZYXEQV
 
        STMTNO=1
        PTR=ZYDOWN(PUROOT)
 100    IF (ZYNTYP(PTR).EQ.24) THEN
            SETPTR=ZYDOWN(PTR)
 200        ITMPTR=ZYDOWN(SETPTR)
            ITMSYM=-ZYDOWN(ITMPTR)
            IF (ITMSYM.LT.0) ITMSYM=-ZYDOWN(-ITMSYM)
            IF (ITMSYM.LT.0) ITMSYM=-ZYDOWN(-ITMSYM)
            CURSUN=GETSU(ITMPTR)
            IF (CURSUN.EQ.-1) RETURN
 300        LASPTR=ITMPTR
            LASSUN=CURSUN
            LASSYM=ITMSYM
            ITMPTR=ZYNEXT(ITMPTR)
            IF (ITMPTR.NE.0) THEN
                ITMSYM=-ZYDOWN(ITMPTR)
                IF (ITMSYM.LT.0) ITMSYM=-ZYDOWN(-ITMSYM)
                IF (ITMSYM.LT.0) ITMSYM=-ZYDOWN(-ITMSYM)
                CURSUN=GETSU(ITMPTR)
                IF (CURSUN.EQ.-1) RETURN
                STATUS=ZYXEQV(LASSYM,LASSUN,ITMSYM,CURSUN)
                IF (STATUS.EQ.-69) THEN
                    CALL ERRMES('Inconsistent EQUIVALENCEs',-1)
                ELSE IF (STATUS.EQ.-70) THEN
                    CALL ERRMES('Dummy argument in EQUIVALENCE',-1)
                    GOTO 400
                END IF
                GOTO 300
            END IF
 400        SETPTR=ZYNEXT(SETPTR)
            IF (SETPTR.GT.0) GOTO 200
        END IF
        PTR=ZYNEXT(PTR)
        STMTNO=STMTNO+1
        IF (PTR.NE.0) GOTO 100
        STMTNO=0
 
        END
C ----------------------------------------------------------------------
C
C       P A S S 4   -   Process the entire file, pass 4
C                       : Global linkage information
C
 
        SUBROUTINE PASS4
 
        COMMON/PUNAMC/PUNAME
        CHARACTER*6 PUNAME
 
        INTEGER SYMPTR,SYMBOL(8),STATUS,PUSYM,TEXT(134),
     +          RESULT(8),PUN
 
        SAVE /PUNAMC/
 
        INTEGER ZYGNSY,ZYXAPU,ZYXAEN,ZYXACO,ZYXAPR,
     +          ZIAND,ZYGPUS
        EXTERNAL ZYGNSY,ZYXAPU,ZYXAEN,ZYXACO,ZYXAPR,
     +           ZIAND,ZYXAAP,ZYXAUS,ZYGPUS
 
        SYMPTR=0
        IF (ZYGNSY(SYMPTR,SYMBOL).EQ.-100)
     +      CALL ERRMES('PASS4: No symbols found',-1001)
 
 100    IF (SYMBOL(1).EQ.4) THEN
            CALL ZYGTST(SYMBOL(2),TEXT)
            CALL ZITOF(TEXT,1,6,PUNAME,.FALSE.)
            IF (ZYXAPU(SYMPTR).NE.-2)
     +          CALL ERRSYM('Program unit occurs twice',SYMPTR,-1)
        ELSE IF (SYMBOL(1).EQ.9) THEN
            IF (ZYXAEN(SYMPTR,ZYGPUS(SYMBOL(3))).NE.-2)
     +          CALL ERRSYM('ENTRY duplicates a global name - ',SYMPTR,
     +                      -1)
        END IF
        IF (ZYGNSY(SYMPTR,SYMBOL).NE.-100) GOTO 100
 
        SYMPTR=0
        PUSYM=0
        PUN=0
        IF (ZYGNSY(SYMPTR,SYMBOL).EQ.-100)
     +      CALL ERRMES('PASS4 PART TWO: No symbols found',-1001)
 
 200    IF (SYMBOL(3).NE.PUN) THEN
            PUN=SYMBOL(3)
            PUSYM=ZYGPUS(PUN)
            CALL ZYGTSY(PUSYM,RESULT)
            CALL ZYGTST(RESULT(2),TEXT)
            CALL ZITOF(TEXT,1,6,PUNAME,.FALSE.)
        END IF
        IF (SYMBOL(1).EQ.2) THEN
            STATUS=ZYXACO(SYMPTR)
            IF (STATUS.EQ.-63) THEN
                CALL ERRSYM('Inconsistent COMMON SAVE-ing for ',SYMPTR,
     +                      -1)
            ELSE IF (STATUS.EQ.-64) THEN
                CALL ERRSYM('Inconsistent size of COMMON ',SYMPTR,-1)
            ELSE IF (STATUS.EQ.-65) THEN
                CALL ERRSYM('COMMON name conflicts with program unit '//
     +                      'name - ',SYMPTR,-1)
            ELSE IF (STATUS.EQ.-66) THEN
                CALL ERRSYM('COMMON block initialised too often - ',
     +                      SYMPTR,-1)
            END IF
        END IF
        IF (ZYGNSY(SYMPTR,SYMBOL).NE.-100) GOTO 200
 
        SYMPTR=0
        PUSYM=0
        PUN=0
        IF (ZYGNSY(SYMPTR,SYMBOL).EQ.-100)
     +      CALL ERRMES('PASS4 PART THREE: No symbols found',-1001)
 300    IF (SYMBOL(3).NE.PUN) THEN
            PUN=SYMBOL(3)
            PUSYM=ZYGPUS(PUN)
            CALL ZYGTSY(PUSYM,RESULT)
            CALL ZYGTST(RESULT(2),TEXT)
            CALL ZITOF(TEXT,1,6,PUNAME,.FALSE.)
        END IF
        IF (SYMBOL(1).EQ.7) THEN
            IF (ZIAND(SYMBOL(6),4096+2)
     +          .EQ.0 .OR. ZIAND(SYMBOL(6),2048).NE.0)
     +      THEN
                STATUS=ZYXAPR(SYMPTR)
                IF (STATUS.EQ.-51) THEN
                    CALL ERRSYM('Inconsistent subprogram type: ',SYMPTR,
     +                          -1)
                ELSE IF (STATUS.EQ.-52) THEN
                    CALL ERRSYM('Inconsistent nu'//'mber of args to ',
     +                          SYMPTR,-1)
                ELSE IF (STATUS.EQ.-53) THEN
                    CALL ERRSYM('Inconsistent arg structure to ',
     +                          SYMPTR,-1)
                ELSE IF (STATUS.EQ.-54) THEN
                    CALL ERRSYM('Inconsistent arg type to ',SYMPTR,-1)
                ELSE IF (STATUS.EQ.-55) THEN
                    CALL ERRSYM('Wrong subprogram datatype: ',SYMPTR,
     +                          -1)
                ELSE IF (STATUS.EQ.-56) THEN
                    CALL ERRSYM('Wrong nu'//'mber of arguments to ',
     +                          SYMPTR,-1)
                ELSE IF (STATUS.EQ.-57) THEN
                    CALL ERRSYM('Wrong type of argument to ',SYMPTR,
     +                          -1)
               ELSE IF (STATUS.EQ.-58) THEN
                    CALL ERRSYM('Unexpected return from ZYXAPR',
     +                          SYMPTR,-1001)
               ELSE IF (STATUS.EQ.-59) THEN
                    CALL ERRSYM('Wrong structure of argument to ',
     +                          SYMPTR,-1)
                ELSE IF (STATUS.EQ.-60) THEN
                    CALL ERRSYM('Character argument too short to ',
     +                          SYMPTR,-1)
                ELSE IF (STATUS.EQ.-61) THEN
                    CALL ERRSYM('External name clashes with common '//
     +                          'block name - ',SYMPTR,-1)
                ELSE IF (STATUS.EQ.-62) THEN
                    CALL ERRSYM('Unused external: ',SYMPTR,-1002)
                ELSE IF (STATUS.NE.-2) THEN
                    CALL ERRMES('UNKNOWN RESULT FROM ZYXAPR',-1001)
                END IF
            END IF
        END IF
        IF (ZYGNSY(SYMPTR,SYMBOL).NE.-100) GOTO 300
 
        CALL ZYXAAP
        CALL ZYXAUS
 
        END
C ----------------------------------------------------------------------
C
C       P R O L I F   -   Process a logical IF statement
C
 
        SUBROUTINE PROLIF(NODE)
        INTEGER NODE
 
        INTEGER STATUS,NTYPE,BITS,DTYPE
 
        INTEGER ZYXGDT,ZYNEXT,ZYNTYP,ZYXGTB,ZIAND
        EXTERNAL ZYXGDT,ZYNEXT,ZYNTYP,ZYXGTB,ZIAND
 
        STATUS=-2
        CALL EXPR(NODE,.FALSE.,0,STATUS)
        IF (STATUS.NE.-2) RETURN
        DTYPE=ZYXGDT(NODE)
        IF (DTYPE.NE.3 .AND. DTYPE.NE.12 .AND.
     +      DTYPE.NE.13) THEN
            CALL ERRMES('Expression in logical IF must be logical',-1)
            RETURN
        END IF
        BITS=ZYXGTB(NODE)
        IF (ZIAND(BITS,8388608+4194304).NE.0) THEN
            CALL ERRMES('Logical IF expression is array/proc',-1)
        ELSE IF (ZIAND(BITS,2097152).NE.0) THEN
            CALL ERRMES('Logical IF expression is constant',-2)
        END IF
        NTYPE=ZYNTYP(ZYNEXT(NODE))
        IF (NTYPE.EQ.61 .OR. NTYPE.EQ.57 .OR.
     +      NTYPE.EQ.58 .OR. NTYPE.EQ.59 .OR.
     +      NTYPE.EQ.60 .OR. NTYPE.EQ.6 .OR.
     +      NTYPE.EQ.56)
     +      CALL ERRMES('Illegal conditional statement in logical IF',
     +                  -1)
 
        END
C ----------------------------------------------------------------------
C
C       P R O B I F   -   Process block IF/ELSEIF statement
C
 
        SUBROUTINE PROBIF(NODE)
        INTEGER NODE
 
        INTEGER STATUS,BITS,DTYPE
 
        INTEGER ZYXGDT,ZYXGTB,ZIAND
        EXTERNAL ZYXGDT,ZYXGTB,ZIAND
 
        STATUS=-2
        CALL EXPR(NODE,.FALSE.,0,STATUS)
        IF (STATUS.EQ.-1) RETURN
        DTYPE=ZYXGDT(NODE)
        IF (DTYPE.NE.3.AND. DTYPE.NE.12 .AND.
     +      DTYPE.NE.13) THEN
            CALL ERRMES('Conditional expression must be type logical',
     +                  -1)
        ELSE
            BITS=ZYXGTB(NODE)
            IF (ZIAND(BITS,4194304+8388608).NE.0) THEN
                CALL ERRMES('Conditional expr is array/proc',-1)
            ELSE IF (ZIAND(BITS,2097152).NE.0) THEN
                CALL ERRMES('Conditional expression is constant',-2)
            END IF
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       P R O P R I   -   Process a PRINT statement
C
 
        SUBROUTINE PROPRI(NODE)
        INTEGER NODE
 
        INTEGER PTR,STATUS
 
        INTEGER ZYNEXT
        EXTERNAL ZYNEXT
 
        STATUS=-2
        CALL FMTID(NODE,STATUS)
        IF (STATUS.EQ.-1) RETURN
        PTR=ZYNEXT(NODE)
        IF (PTR.NE.0) CALL IOLIST(PTR)
 
        END
C ----------------------------------------------------------------------
C
C       P R O W R I   -   Process a WRITE statement
C
 
        SUBROUTINE PROWRI(NODE)
        INTEGER NODE
 
        INTEGER PTR,STATUS
 
        INTEGER ZYNTYP,ZYNEXT
        EXTERNAL ZYNTYP,ZYNEXT
 
        STATUS=-2
        CALL CILIST(NODE,STATUS)
        IF (STATUS.EQ.-1) RETURN
        PTR=ZYNEXT(NODE)
        IF (PTR.NE.0) CALL IOLIST(PTR)
 
        END
C ----------------------------------------------------------------------
C
C       P R O R E A   -   Process a READ statement
C
 
        SUBROUTINE PROREA(NODE)
        INTEGER NODE
 
        INTEGER PTR,NTYPE,STATUS,TMP
 
        INTEGER ZYNEXT,ZYNTYP,ZYCRND,ZYXGDT
        EXTERNAL ZYNEXT,ZYNTYP,ZYCRND,ZYCHNT,ZYADSN,ZYREPL,ZYXGDT
 
        STATUS=-2
        NTYPE=ZYNTYP(NODE)
        IF (NTYPE.EQ.123) THEN
            CALL FMTID(NODE,STATUS)
        ELSE IF (NTYPE.EQ.68) THEN
            CALL CILIST(NODE,STATUS)
        ELSE IF (NTYPE.EQ.124) THEN
C Could be a format-expression or ci-list - we have to check
C Assume it is going to be a format expression (type char)
            CALL ZYCHNT(NODE,101)
            CALL EXPR(NODE,.FALSE.,0,STATUS)
            IF (STATUS.EQ.-1) RETURN
            IF (ZYXGDT(NODE).EQ.1) THEN
C type integer - it is a cilist - say so (remove the b..... parentheses)
                CALL ZYCHNT(NODE,122)
                PTR=ZYCRND(68,0)
                CALL ZYREPL(NODE,PTR)
                CALL ZYADSN(PTR,NODE)
            ELSE IF (ZYXGDT(NODE).NE.6) THEN
                CALL ERRMES('Invalid READ statement',-1)
                STATUS=-1
            END IF
        ELSE IF (NTYPE.EQ.101) THEN
C Parenthesised format expression - no N_FMTID node.
            CALL EXPR(NODE,.FALSE.,0,STATUS)
        ELSE
            CALL ERRMES('PROREA: DON''T UNDERSTAND TREE',-1001)
        END IF
        IF (STATUS.EQ.-1) RETURN
        PTR=ZYNEXT(NODE)
        IF (PTR.NE.0) CALL IOLIST(PTR)
 
        END
C ----------------------------------------------------------------------
C
C       P R O A U X   -   Process an auxiliary i/o statement
C
 
        SUBROUTINE PROAUX(NODE)
        INTEGER NODE
 
        INTEGER STATUS,PTR
 
        INTEGER ZYNTYP,ZYXGDT,ZYXGTB,ZIAND,ZYDOWN,ZYNEXT
        EXTERNAL ZYNTYP,ZYXGDT,ZYXGTB,ZIAND,ZYDOWN,ZYNEXT
 
        LOGICAL BADP
        INTEGER ARGN
 
        BADP(ARGN)=ZIAND(ZYXGTB(ARGN),4194304+8388608).NE.0
 
        STATUS=-2
        IF (ZYNTYP(NODE).EQ.122) THEN
            PTR=ZYDOWN(NODE)
            IF (ZYNTYP(PTR).NE.17) THEN
                CALL EXPR(PTR,.FALSE.,0,STATUS)
                IF (STATUS.EQ.-1) RETURN
                IF (ZYXGDT(PTR).NE.1) THEN
                    CALL ERRMES('Unit-identifier must be integer',-1)
                    RETURN
                ELSE IF (BADP(PTR)) THEN
                    CALL ERRMES('Unit-identifier is array/proc',-1)
                    RETURN
                END IF
            END IF
            PTR=ZYNEXT(NODE)
        ELSE
            PTR=NODE
        END IF
        IF (PTR.NE.0) CALL CILIST(PTR,STATUS)
 
 
        END
C ----------------------------------------------------------------------
C
C
C       P R O P A R   -   Process a PARAMETER statement
C
 
        SUBROUTINE PROPAR(NODE)
        INTEGER NODE
 
        INTEGER PTR,STATUS,SYMPTR,SYMBOL(8),NTYPE
 
        INTEGER ZYDOWN,ZYNEXT,ZYXGVA,ZYXGDT
        EXTERNAL ZYDOWN,ZYNEXT,ZYSATT,ZYSABT,ZYXGVA,ZYGTSY,
     +           ZYXGDT
 
        PTR=NODE
 100    CALL EXPR(ZYNEXT(ZYDOWN(PTR)),.TRUE.,0,STATUS)
        IF (STATUS.EQ.-2) THEN
            SYMPTR=-ZYDOWN(ZYDOWN(PTR))
            CALL ZYSABT(SYMPTR,6,262144)
            CALL ZYGTSY(SYMPTR,SYMBOL)
            NTYPE=ZYXGDT(ZYNEXT(ZYDOWN(PTR)))
            IF (SYMBOL(4).EQ.1) THEN
                IF (NTYPE.EQ.1) THEN
                    CALL ZYSATT(SYMPTR,8,
     +                   ZYXGVA(ZYNEXT(ZYDOWN(PTR))))
                ELSE IF (NTYPE.EQ.6 .OR. NTYPE.EQ.3
     +                   .OR. NTYPE.EQ.12
     +                   .OR. NTYPE.EQ.13) THEN
                    CALL ERRMES ('Invalid integer PARAMETER'//
     +                   ' expression',-1)
                ELSE
                    CALL ERRMES ('Integer PARAMETER expression n'//
     +                   'ot integer',-1002)
                ENDIF
            ELSE IF (SYMBOL(4).EQ.6) THEN
                IF (NTYPE.EQ.6) THEN
                CALL ZYSATT(SYMPTR,8,
     +               ZYXGVA(ZYNEXT(ZYDOWN(PTR))))
                ELSE
                CALL ERRMES ('Invalid character PARAMETER'//
     +               ' expression',-1)
                ENDIF
            ELSE IF (SYMBOL(4).EQ.3 .OR.
     +               SYMBOL(4).EQ.12 .OR.
     +               SYMBOL(4).EQ.13) THEN
                IF (NTYPE.NE.3 .AND. NTYPE.NE.12
     +               .AND. NTYPE.NE.13)
     +               CALL ERRMES ('Invalid logical PARAMETER'//
     +               ' expression',-1)
            ELSE IF (NTYPE.EQ.6) THEN
                CALL ERRMES ('Invalid character expression in'//
     +                        ' PARAMETER',-1)
            ELSE IF (NTYPE.EQ.3 .OR. NTYPE.EQ.12
     +               .OR. NTYPE.EQ.13) THEN
                CALL ERRMES ('Invalid logical expression in'//
     +                        ' PARAMETER',-1)
            ENDIF
        END IF
        PTR=ZYNEXT(PTR)
        IF (PTR.NE.0) GOTO 100
 
        END
C ----------------------------------------------------------------------
C
C       P R O T Y P   -   Process a type or DIMENSION statement
C
 
        SUBROUTINE PROTYP(NODE)
        INTEGER NODE
 
        INTEGER PTR,STATUS,P2,NTYPE
 
        INTEGER ZYDOWN,ZYNTYP,ZYNEXT,ZYXGDT,ZYXGVA
        EXTERNAL ZYDOWN,ZYNTYP,ZYNEXT,ZYXGDT,ZYXSVA,ZYXGVA
 
        PTR=NODE
        STATUS=-2
 100    NTYPE=ZYNTYP(PTR)
        IF (NTYPE.EQ.21) THEN
            CALL ARRAYD(PTR)
        ELSE IF (NTYPE.EQ.10 .OR. NTYPE.EQ.13 .OR.
     +           NTYPE.EQ.9) THEN
            P2=ZYDOWN(PTR)
            IF (P2.NE.0) THEN
                CALL EXPR(P2,.TRUE.,0,STATUS)
                IF (STATUS.EQ.-2) THEN
                    IF (ZYXGDT(P2).NE.1) THEN
                        CALL ERRMES('Invalid expression type',-1)
                    ELSE
                        CALL CHKTYP(NTYPE,ZYXGVA(P2))
                    END IF
                END IF
            END IF
        ELSE IF (NTYPE.EQ.14) THEN
            P2=ZYDOWN(PTR)
            IF (P2.EQ.0) THEN
C Nothing to do
                CONTINUE
            ELSE IF (ZYNTYP(P2).EQ.17) THEN
                CALL ZYXSVA(P2,0)
            ELSE
                CALL EXPR(P2,.TRUE.,0,STATUS)
                IF (STATUS.EQ.-2) THEN
                    IF (ZYXGDT(P2).NE.1) THEN
                        CALL ERRMES('Invalid expression type',-1)
                        STATUS=-1
                    ELSE IF (ZYXGVA(P2).LE.0) THEN
                        CALL ERRMES('Character length must be positive',
     +                              -1)
                        STATUS=-1
                    END IF
                END IF
            END IF
        ELSE IF (NTYPE.EQ.31) THEN
            P2=ZYDOWN(PTR)
            IF (ZYNTYP(P2).EQ.21) CALL ARRAYD(P2)
            P2=ZYNEXT(P2)
            IF (ZYNTYP(P2).EQ.17) THEN
                CALL ZYXSVA(P2,0)
            ELSE
                CALL EXPR(P2,.TRUE.,0,STATUS)
                IF (STATUS.EQ.-2 .AND. ZYXGDT(P2).NE.1) THEN
                    CALL ERRMES('Invalid expression type',-1)
                    STATUS=-1
                END IF
            END IF
        END IF
        IF (STATUS.EQ.-1) RETURN
        PTR=ZYNEXT(PTR)
        IF (PTR.NE.0) GOTO 100
 
        END
C ----------------------------------------------------------------------
C
C       P R O C O M   -   Process a COMMON statement
C
 
        SUBROUTINE PROCOM(NODE,BLKDTA)
        INTEGER NODE
        LOGICAL BLKDTA
 
        COMMON/CONTXT/PUN,STMTNO
        INTEGER PUN,STMTNO
 
        INTEGER PTR,COMPTR,SYMBOL(8),TEXT(8),P2,ELTPTR
 
        SAVE TEXT
 
        INTEGER ZYDOWN,ZYNEXT,ZYNTYP,ZYFSYM,ZIAND,ZYXATC
        EXTERNAL ZYDOWN,ZYNEXT,ZYNTYP,ZYFSYM,ZIAND,ZYXATC
 
        DATA TEXT/36,67,79,77,77,79,78,129/
 
        PTR=NODE
 100    P2=ZYDOWN(PTR)
        IF (ZYNTYP(PTR).EQ.27) THEN
C Actually, blank common is not illegal in itself, it is just illegal
C to initially define (via DATA) anything in it...
            IF (BLKDTA)
     +          CALL ERRMES('Blank COMMON illegal in BLOCK DATA',-1)
            COMPTR=ZYFSYM(TEXT,PUN,SYMBOL)
            IF (COMPTR.EQ.-1)
     +          CALL ERRMES('Couldn''t find Blank Common',-1001)
        ELSE
            COMPTR=-ZYDOWN(P2)
            P2=ZYNEXT(P2)
        END IF
        P2=ZYDOWN(P2)
 200    IF (ZYNTYP(P2).EQ.21) THEN
            CALL ARRAYD(P2)
            ELTPTR=ZYDOWN(P2)
        ELSE
            ELTPTR=P2
        END IF
        ELTPTR=-ZYDOWN(ELTPTR)
        CALL ZYGTSY(ELTPTR,SYMBOL)
        IF (ZIAND(SYMBOL(6),4).NE.0 .OR.
     +      SYMBOL(1).EQ.4) THEN
            CALL ERRMES('Invalid variable in COMMON',-1)
        ELSE IF (ZYXATC(COMPTR,ELTPTR).EQ.-1) THEN
            CALL ERRMES('Variable occurs more than once in COMMON',-1)
        END IF
        P2=ZYNEXT(P2)
        IF (P2.NE.0) GOTO 200
        PTR=ZYNEXT(PTR)
        IF (PTR.NE.0) GOTO 100
 
        END
C ----------------------------------------------------------------------
C
C       P R O D A T   -   Process a DATA statement
C
 
        SUBROUTINE PRODAT(NODE,BLKDTA)
        INTEGER NODE
        LOGICAL BLKDTA
 
        INTEGER PTR,PTRI,STATUS,NTYPE,SYMBOL(8),PLACE,OFFSET
 
        INTEGER ZYDOWN,ZYNEXT,ZYXGVA,ZYXGTB,ZYXGDT,ZYNTYP,
     +          ZIAND,ZYXGEL,ZYUP
        EXTERNAL ZYDOWN,ZYNEXT,ZYXGVA,ZYXGTB,ZYXGDT,ZYNTYP,
     +          ZIAND,ZYXGEL,ZYUP,ZYXGVL
 
        PTR=NODE
        STATUS=-2
 
 100    PTRI=ZYDOWN(PTR)
        CALL DVINIT(ZYDOWN(ZYNEXT(PTRI)),ZYUP(NODE))
        PTRI=ZYDOWN(PTRI)
        CALL INIDID
 
 200    NTYPE=ZYNTYP(PTRI)
        IF (NTYPE.EQ.108) THEN
            CALL ZYGTSY(-ZYDOWN(PTRI),SYMBOL)
            IF (ZIAND(SYMBOL(6),4).NE.0) THEN
                CALL ERRMES('Dummy argument in DATA',-1)
                RETURN
            ELSE
                CALL ZYXGVL(-ZYDOWN(PTRI),PLACE,OFFSET)
                IF (BLKDTA.NEQV.PLACE.GT.0) THEN
                    IF (BLKDTA) THEN
                        CALL ERRMES(
     +'Only COMMON may be initialised in BLOCK DATA',-1)
                    ELSE
                        CALL ERRMES(
     +'COMMON may only be initialised in BLOCK DATA',-1)
                    END IF
                END IF
            END IF
            IF (SYMBOL(7).EQ.0) THEN
                CALL DV(SYMBOL(4),1)
            ELSE
                CALL DV(SYMBOL(4),ZYXGEL(-ZYDOWN(PTRI)))
            END IF
            PTRI=ZYNEXT(PTRI)
        ELSE IF (NTYPE.EQ.104 .OR. NTYPE.EQ.103) THEN
            CALL EXPR(PTRI,.TRUE.,1,STATUS)
            IF (STATUS.EQ.-1) RETURN
            CALL DV(ZYXGDT(PTRI),1)
            PTRI=ZYNEXT(PTRI)
        ELSE IF (NTYPE.EQ.48) THEN
            CALL ENDDID(PTRI,STATUS)
            IF (STATUS.EQ.-1) RETURN
        ELSE
C NTYPE=N_DATA_IMPDO
            CALL DID(PTRI,STATUS)
            IF (STATUS.EQ.-1) RETURN
        END IF
        IF (PTRI.NE.0) GOTO 200
C Check if there are more data values.
        CALL DVEND
 
        PTR=ZYNEXT(PTR)
        IF (PTR.NE.0) GOTO 100
 
        END
C ----------------------------------------------------------------------
C
C       P R O A S G   -   Process an assignment statement
C
 
        SUBROUTINE PROASG(NODE)
        INTEGER NODE
 
        INTEGER SYMBOL(8),PTR,P2,STATUS,NTYPE
 
        LOGICAL COMPAT
        INTEGER ZYDOWN,ZYNEXT,ZYNTYP,ZYXGTB,ZIAND,ZYXGDT
        EXTERNAL ZYDOWN,ZYNEXT,ZYNTYP,ZYXGTB,ZYGTSY,ZIAND,ZYXGDT
 
        PTR=NODE
        STATUS=-2
        CALL EXPR(PTR,.FALSE.,0,STATUS)
        IF (STATUS.NE.-2) RETURN
        P2=PTR
        NTYPE=ZYNTYP(PTR)
        IF (NTYPE.EQ.103) THEN
            P2=ZYDOWN(PTR)
            NTYPE=ZYNTYP(P2)
        END IF
        IF (NTYPE.EQ.104) P2=ZYDOWN(P2)
        CALL ZYGTSY(-ZYDOWN(P2),SYMBOL)
        IF (SYMBOL(1).EQ.4 .OR.
     +      SYMBOL(1).EQ.9) THEN
            IF (SYMBOL(4).LT.0) THEN
                CALL ERRMES('Illegal assignment to subprogram name',
     +                      -1)
                RETURN
            END IF
        ELSE IF (SYMBOL(1).NE.5) THEN
            CALL ERRMES('PROASG: Invalid parse tree detected',-1001)
        END IF
        IF (ZIAND(ZYXGTB(PTR),4194304).NE.0) THEN
            CALL ERRMES('Missing subscript on lhs of assigment',-1)
            RETURN
        END IF
        P2=ZYNEXT(PTR)
        CALL EXPR(P2,.FALSE.,0,STATUS)
        IF (STATUS.NE.-2) RETURN
        IF (ZIAND(ZYXGTB(P2),4194304).NE.0) THEN
            CALL ERRMES('Missing subscript on rhs of assignment',-1)
        ELSE
            IF (.NOT.COMPAT(ZYXGDT(PTR),ZYXGDT(P2)))
     +          CALL ERRMES('Incompatible types in assignment',-1)
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       P R O D O   -   Process a DO statement
C
 
        SUBROUTINE PRODO(NODE)
        INTEGER NODE
 
        COMMON/DOSTK/DOLVL,DOLBL,DOIDX
        INTEGER DOLVL,DOLBL(25),DOIDX(25)
 
        SAVE /DOSTK/
 
        INTEGER PTR,SYMBOL(8),STATUS,TEXT(9),DTYPE
 
        INTEGER CTOI,ZYNEXT,ZYDOWN,ZYXGDT
        EXTERNAL CTOI,ZYNEXT,ZYDOWN,ZYXGDT,ZYGTSY
 
        IF (DOLVL.EQ.25)
     +      CALL ERRMES('DO loops nested too deeply',-1001)
        CALL ZYGTSY(-ZYDOWN(NODE),SYMBOL)
        CALL ZYGTST(SYMBOL(2),TEXT)
        PTR=1
        DOLBL(DOLVL+1)=CTOI(TEXT,PTR)
        PTR=ZYDOWN(ZYNEXT(NODE))
        DOIDX(DOLVL+1)=-ZYDOWN(PTR)
        CALL ZYGTSY(DOIDX(DOLVL+1),SYMBOL)
        IF (SYMBOL(4).NE.1 .AND.
     +      SYMBOL(4).NE.14 .AND.
     +      SYMBOL(4).NE.2 .AND.
     +      SYMBOL(4).NE.5 .AND.
     +      SYMBOL(4).NE.15) THEN
            CALL ERRMES('Invalid datatype of DO control variable',-1)
            RETURN
        ELSE IF (SYMBOL(1).EQ.5 .AND.
     +      SYMBOL(7).NE.0) THEN
            CALL ERRMES('DO control variable must be scalar',-1)
            RETURN
        END IF
        PTR=ZYNEXT(PTR)
 
 100    CALL EXPR(PTR,.FALSE.,0,STATUS)
        IF (STATUS.EQ.-1) RETURN
        DTYPE=ZYXGDT(PTR)
        IF (DTYPE.NE.1 .AND. DTYPE.NE.14 .AND.
     +      DTYPE.NE.2 .AND. DTYPE.NE.5 .AND.
     +      DTYPE.NE.15) THEN
            CALL ERRMES('Invalid datatype of DO limit expression',-1)
            RETURN
        END IF
        PTR=ZYNEXT(PTR)
        IF (PTR.NE.0) GOTO 100
        DOLVL=DOLVL+1
 
        END
C ----------------------------------------------------------------------
C
C       P R O G O A   -   Process assigned GOTO
C
 
        SUBROUTINE PROGOA(NODE)
        INTEGER NODE
 
        INTEGER SYMBOL(8)
 
        INTEGER ZYDOWN,ZIAND
        EXTERNAL ZYDOWN,ZIAND,ZYGTSY
 
        CALL ZYGTSY(-ZYDOWN(NODE),SYMBOL)
        IF (SYMBOL(4).NE.1 .OR.
     +      SYMBOL(7).NE.0) THEN
            CALL ERRMES('Assigned GOTO variable must be integer scalar',
     +                  -1)
        ELSE IF (ZIAND(SYMBOL(6),16).EQ.0) THEN
            CALL ERRMES('Assigned GOTO variable never assigned',-1)
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       P R O G O C   -   Process computed GOTO
C
 
        SUBROUTINE PROGOC(NODE)
        INTEGER NODE
 
        INTEGER PTR,STATUS
 
        INTEGER ZYNEXT,ZYXGDT
        EXTERNAL ZYNEXT,ZYXGDT
 
        STATUS=-2
        PTR=ZYNEXT(NODE)
        CALL EXPR(PTR,.FALSE.,0,STATUS)
        IF (STATUS.EQ.-1) RETURN
        IF (ZYXGDT(PTR).NE.1)
     +      CALL ERRMES('Computed GOTO expr must be of type integer',
     +                  -1)
 
        END
C ----------------------------------------------------------------------
C
C       P R O S F   -   Process statement function definition
C
 
        SUBROUTINE PROSF(NODE)
        INTEGER NODE
 
 
        INTEGER PTR,SYMBOL(8),SYMPTR,P2,ASYMP(20),I,
     +          N,ADTYPE(20),ACHLEN(20),STATUS
 
        LOGICAL COMPAT
 
        INTEGER ZYDOWN,ZYNEXT,ZYXGDT,ZYXGVA
        EXTERNAL ZYDOWN,ZYNEXT,ZYXGDT,ZYXGVA,ZYGTSY,ZYXSFA
 
        SYMPTR=-ZYDOWN(NODE)
        CALL ZYGTSY(SYMPTR,SYMBOL)
        PTR=ZYNEXT(NODE)
        P2=ZYDOWN(PTR)
        N=0
 
 100    N=N+1
        ASYMP(N)=-ZYDOWN(P2)
        DO 200 I=1,N-1
            IF (ASYMP(I).EQ.ASYMP(N)) THEN
                CALL ERRMES('Duplicate statement fn dummy arguments',
     +                      -1)
                RETURN
            END IF
 200    CONTINUE
        CALL EXPR(P2,.FALSE.,0,STATUS)
        IF (STATUS.EQ.-1) RETURN
        ADTYPE(N)=ZYXGDT(P2)
        IF (ADTYPE(N).EQ.6) THEN
            ACHLEN(N)=ZYXGVA(P2)
            IF (ACHLEN(N).LT.1) THEN
                CALL ERRMES('Illegal 97 len spec for stmt fn dummy',
     +                      -1)
                RETURN
            END IF
        ELSE
            ACHLEN(N)=0
        END IF
        P2=ZYNEXT(P2)
        IF (P2.NE.0) GOTO 100
 
        CALL ZYXSFA(SYMPTR,N,ADTYPE,ACHLEN)
 
        PTR=ZYNEXT(PTR)
        CALL EXPR(PTR,.FALSE.,SYMPTR*1000,STATUS)
        IF (STATUS.NE.-1) THEN
            IF (.NOT.COMPAT(ZYXGDT(PTR),SYMBOL(4)))
     +          CALL ERRMES('Incompatible types in stmt fn',-1)
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       P R O A S S   -   Process ASSIGN statement
C
 
        SUBROUTINE PROASS(NODE)
        INTEGER NODE
 
        INTEGER SYMBOL(8)
 
        INTEGER ZYDOWN,ZYNEXT
        EXTERNAL ZYDOWN,ZYNEXT,ZYGTSY
 
        CALL ZYGTSY(-ZYDOWN(ZYNEXT(NODE)),SYMBOL)
        IF (SYMBOL(7).NE.0 .OR.
     +      SYMBOL(4).NE.1)
     +      CALL ERRMES('ASSIGN variable must be integer scalar',-1)
 
        END
C ----------------------------------------------------------------------
C
C       P R O C A L   -   Process a CALL statement
C
 
        SUBROUTINE PROCAL(NODE)
        INTEGER NODE
 
        COMMON/DOSTK/DOLVL,DOLBL,DOIDX
        INTEGER DOLVL,DOLBL(25),DOIDX(25)
 
        COMMON/CONTXT/PUN,STMTNO
        INTEGER PUN,STMTNO
 
        SAVE /CONTXT/,/DOSTK/
 
        INTEGER PTR,STATUS,TMP,ARGNUM,I
 
        INTEGER ZYDOWN,ZYNEXT,ZYUP,ZYNTYP,ZYXPAS
        EXTERNAL ZYDOWN,ZYNEXT,ZYUP,ZYNTYP,ZYXPAS,ZYXSUD
 
        PTR=NODE
 100    PTR=ZYNEXT(PTR)
        IF (PTR.NE.0) THEN
            CALL EXPR(PTR,.FALSE.,0,STATUS)
            IF (STATUS.EQ.-1) RETURN
            GOTO 100
        END IF
        IF (ZYXPAS(ZYUP(NODE),.FALSE.,STMTNO).EQ.-1) THEN
            CALL ERRMES('Inconsistent argument lists',-1)
        ELSE IF (DOLVL.GT.0) THEN
            PTR=ZYNEXT(NODE)
            ARGNUM=0
 200        IF (PTR.NE.0) THEN
                TMP=-ZYDOWN(PTR)
                ARGNUM=ARGNUM+1
                DO 300 I=1,DOLVL
                    IF (TMP.EQ.DOIDX(I)) THEN
                        IF (ZYNTYP(PTR).EQ.108) THEN
                            CALL ZYXSUD(-ZYDOWN(NODE),
     +                                        ARGNUM,STMTNO)
                        END IF
                    END IF
 300            CONTINUE
                PTR=ZYNEXT(PTR)
                GOTO 200
            END IF
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       P R O R E T   -   Process a RETURN statement
C
 
        SUBROUTINE PRORET(NODE)
        INTEGER NODE
 
        INTEGER STATUS
 
        INTEGER ZYXGDT,ZYNTYP,ZYUP
        EXTERNAL ZYXGDT,ZYNTYP,ZYUP
 
        IF (NODE.NE.0) THEN
            IF (ZYNTYP(ZYUP(ZYUP(NODE))).EQ.56) THEN
              IF (ZYNTYP(ZYUP(ZYUP(ZYUP(NODE)))).NE.4) THEN
                  CALL ERRMES('Alternate RETURN only allowed '//
     +                        'in SUBROUTINE',-1)
                  RETURN
              ENDIF
            ELSE IF (ZYNTYP(ZYUP(ZYUP(NODE))).NE.4) THEN
                CALL ERRMES('Alternate RETURN only allowed '//
     +                      'in SUBROUTINE',-1)
                RETURN
            END IF
            CALL EXPR(NODE,.FALSE.,0,STATUS)
            IF (STATUS.EQ.-1) RETURN
            IF (ZYXGDT(NODE).NE.1)
     +          CALL ERRMES('RETURN expression must be of type integer',
     +                      -1)
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       P R O S U B   -   Process subroutine/function/entry statement
C
 
        SUBROUTINE PROSUB(NODE)
        INTEGER NODE
 
        INTEGER PTR,SYMPTR,NARGS,ARGLST(160),I,J
 
        INTEGER ZYDOWN,ZYNEXT,ZYNTYP
        EXTERNAL ZYDOWN,ZYNEXT,ZYNTYP,ZYXSPA
 
        SYMPTR=-ZYDOWN(NODE)
        NARGS=0
        PTR=ZYNEXT(NODE)
        IF (PTR.NE.0) PTR=ZYDOWN(PTR)
 
 100    IF (PTR.NE.0) THEN
            NARGS=NARGS+1
            IF (NARGS.GT.160) THEN
                CALL ERRMES('Too many dummy arguments',-1)
                RETURN
            END IF
            IF (ZYNTYP(PTR).EQ.108) THEN
                ARGLST(NARGS)=-ZYDOWN(PTR)
            ELSE
                ARGLST(NARGS)=-NARGS
            END IF
            PTR=ZYNEXT(PTR)
            GOTO 100
        END IF
        DO 300 I=1,NARGS-1
            DO 200 J=I+1,NARGS
                IF (ARGLST(I).EQ.ARGLST(J)) THEN
                    CALL ERRMES('Duplicate dummy arguments',-1)
                    RETURN
                END IF
 200        CONTINUE
 300    CONTINUE
        CALL ZYXSPA(SYMPTR,NARGS,ARGLST)
 
        END
C ----------------------------------------------------------------------
C
C       P R O A I F   -   Process arithmetic IF statement
C
 
        SUBROUTINE PROAIF(NODE)
        INTEGER NODE
 
        INTEGER STATUS,BITS,DTYPE
 
        INTEGER ZYXGDT,ZYXGTB,ZIAND
        EXTERNAL ZYXGDT,ZYXGTB,ZIAND
 
        STATUS=-2
        CALL EXPR(NODE,.FALSE.,0,STATUS)
        IF (STATUS.EQ.-2) THEN
            DTYPE=ZYXGDT(NODE)
            IF (DTYPE.NE.1 .AND. DTYPE.NE.14 .AND.
     +          DTYPE.NE.2 .AND. DTYPE.NE.5 .AND.
     +          DTYPE.NE.15) THEN
                CALL ERRMES('Wrong expression type in arithmetic IF',
     +                      -1)
            ELSE
                BITS=ZYXGTB(NODE)
                IF (ZIAND(BITS,4194304+8388608).NE.0) THEN
                    CALL ERRMES('Arithmetic IF expr is array/proc',-1)
                ELSE IF (ZIAND(BITS,2097152).NE.0) THEN
                    CALL ERRMES('Arithmetic IF expression is constant',
     +                          -2)
                END IF
            END IF
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       P R O P A U   -   Process a PAUSE or STOP statement
C
 
        SUBROUTINE PROPAU(NODE)
        INTEGER NODE
 
        INTEGER NTYPE,TEXT(134),STATUS
 
        INTEGER ZYNTYP,ZYDOWN,LENGTH
        EXTERNAL ZYNTYP,ZYDOWN,LENGTH
 
        IF (NODE.NE.0) THEN
            NTYPE=ZYNTYP(NODE)
            IF (NTYPE.EQ.107) THEN
                CALL ZYGTST(-ZYDOWN(NODE),TEXT)
                IF (LENGTH(TEXT).GT.5)
     +              CALL ERRMES('Too many digits in STOP/PAUSE code',
     +                          -1)
            ELSE IF (NTYPE.NE.114) THEN
                CALL ERRMES('PROPAU: CORRUPT PARSE TREE',-1001)
            END IF
            CALL EXPR(NODE,.TRUE.,0,STATUS)
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       P R O S A V   -   Process a SAVE statement
C
 
        SUBROUTINE PROSAV(NODE,MAIN)
        INTEGER NODE
        LOGICAL MAIN
 
        COMMON/CONTXT/PUN,STMTNO
        INTEGER PUN,STMTNO
 
        INTEGER PTR,SYMBOL(8),SPTR,STATUS
 
        SAVE /CONTXT/
 
        INTEGER ZYNEXT,ZYNTYP,ZYDOWN,ZIAND,ZYGNSW
        EXTERNAL ZYNEXT,ZYNTYP,ZYDOWN,ZIAND,ZYGNSW,ZYGTSY,ZYSATT
 
        PTR=NODE
        IF (PTR.EQ.0) THEN
            IF (MAIN) RETURN
            SPTR=0
 100        STATUS=ZYGNSW(SPTR,PUN,SYMBOL)
            IF (STATUS.EQ.-100) RETURN
            IF (SYMBOL(1).EQ.2)
     +          CALL ZYSATT(SPTR,8,3)
            GOTO 100
        END IF
 200    CALL ZYGTSY(-ZYDOWN(PTR),SYMBOL)
        IF (ZYNTYP(PTR).EQ.108) THEN
            IF (ZIAND(SYMBOL(6),4).NE.0)
     +          CALL ERRMES('Dummy argument in SAVE statement',-1)
            IF (ZIAND(SYMBOL(6),1024).NE.0)
     +          CALL ERRMES('Common block item in SAVE statement',-1)
            IF (SYMBOL(1).EQ.4)
     +          CALL ERRMES('Program-unit name in SAVE statement',-1)
            IF (SYMBOL(1).EQ.9)
     +          CALL ERRMES('Entry point name in SAVE statement',-1)
        ELSE
            CALL ZYSATT(-ZYDOWN(PTR),8,3)
        END IF
        PTR=ZYNEXT(PTR)
        IF (PTR.NE.0) GOTO 200
 
        END
C ----------------------------------------------------------------------
C
C       P R O F M T   -   Process a FORMAT statement
C
 
        SUBROUTINE PROFMT(NODE)
        INTEGER NODE
 
        INTEGER PTR,STATUS,NTYPE,NEXT,DEPTH
 
        INTEGER ZYNTYP,ZYNEXT,ZYDOWN,ZYUP
        EXTERNAL ZYNTYP,ZYNEXT,ZYDOWN,ZYUP
 
        PTR=NODE
        IF (PTR.EQ.0) RETURN
        STATUS=-2
        DEPTH=0
 100    NTYPE=ZYNTYP(PTR)
        IF (NTYPE.EQ.117 .OR. NTYPE.EQ.79) THEN
            NEXT=ZYDOWN(PTR)
            DEPTH=DEPTH+1
        ELSE
            IF (NTYPE.EQ.114 .OR. NTYPE.EQ.113) THEN
                CALL EXPR(PTR,.FALSE.,0,STATUS)
                IF (STATUS.EQ.-1) RETURN
            END IF
 200        NEXT=ZYNEXT(PTR)
            IF (NEXT.EQ.0 .AND. DEPTH.GT.0) THEN
                PTR=ZYUP(PTR)
                DEPTH=DEPTH-1
                GOTO 200
            END IF
        END IF
        PTR=NEXT
        IF (PTR.NE.0) GOTO 100
 
        END
C ----------------------------------------------------------------------
C
C       I N I D I D   -   Initialise data_implied_do handling
C
C       D I D   -   enter a data_implied_do loop
C
C       E N D D I D   -   end a data_implied_do loop
C
 
        SUBROUTINE INIDID
        INTEGER PTRI,STATUS
 
        COMMON/DIDCMN/SP,IDOSTK
        INTEGER SP,IDOSTK(5,25)
 
        INTEGER PTR,I
 
        SAVE /DIDCMN/
 
        INTEGER ZYDOWN,ZYPREV,ZYNEXT,ZYUP,ZYXGVA,ZYXGDT
        EXTERNAL ZYDOWN,ZYPREV,ZYNEXT,ZYUP,ZYXGVA,ZYXGDT
 
C
C IDOSTK:   1 = index symbol pointer
C           2 = current value
C           3 = upper bound
C           4 = step value
C           5 = first subnode
C
 
        SP=0
        RETURN
 
        ENTRY DID(PTRI,STATUS)
 
        IF (SP.EQ.25) THEN
            CALL ERRMES('DATA-implied DO stack overflow',-1)
            STATUS=-1
            RETURN
        END IF
        PTRI=ZYDOWN(PTRI)
        IDOSTK(5,SP+1)=PTRI
        PTR=ZYDOWN(ZYPREV(PTRI))
        IDOSTK(1,SP+1)=-ZYDOWN(PTR)
        DO 100 I=1,SP-1
            IF (IDOSTK(1,I).EQ.IDOSTK(1,SP+1)) THEN
                CALL ERRMES('Duplicate DATA-implied DO loop variable',
     +                      -1)
                STATUS=-1
                RETURN
            END IF
 100    CONTINUE
        PTR=ZYNEXT(PTR)
        CALL EXPR(PTR,.TRUE.,1,STATUS)
        IF (STATUS.EQ.-1) RETURN
        IF (ZYXGDT(PTR).NE.1) THEN
            CALL ERRMES('Limit expression must be integer',-1)
            STATUS=-1
            RETURN
        END IF
        IDOSTK(2,SP+1)=ZYXGVA(PTR)
        PTR=ZYNEXT(PTR)
        CALL EXPR(PTR,.TRUE.,1,STATUS)
        IF (STATUS.EQ.-1) RETURN
        IF (ZYXGDT(PTR).NE.1) THEN
            CALL ERRMES('Limit expression must be integer',-1)
            STATUS=-1
            RETURN
        END IF
        IDOSTK(3,SP+1)=ZYXGVA(PTR)
        IDOSTK(4,SP+1)=1
        PTR=ZYNEXT(PTR)
        IF (PTR.NE.0) THEN
            CALL EXPR(PTR,.TRUE.,1,STATUS)
            IF (STATUS.EQ.-1) RETURN
            IF (ZYXGDT(PTR).NE.1) THEN
                CALL ERRMES('Limit expression must be integer',-1)
                STATUS=-1
                RETURN
            END IF
            IDOSTK(4,SP+1)=ZYXGVA(PTR)
        END IF
        SP=SP+1
        RETURN
 
        ENTRY ENDDID(PTRI,STATUS)
 
        IDOSTK(2,SP)=IDOSTK(2,SP)+IDOSTK(4,SP)
        IF (IDOSTK(2,SP).LE.IDOSTK(3,SP)) THEN
            PTRI=IDOSTK(5,SP)
        ELSE
            SP=SP-1
            PTRI=ZYNEXT(ZYUP(PTRI))
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       E V D V A R   -   Evaluate Data_implied_do_loop variable
C
 
        SUBROUTINE EVDVAR(SYMPTR,VALUE,STATUS)
        INTEGER SYMPTR,VALUE,STATUS
 
        COMMON/DIDCMN/SP,IDOSTK
        INTEGER SP,IDOSTK(5,25)
 
        INTEGER I
 
        SAVE /DIDCMN/
 
        DO 100 I=1,SP
            IF (SYMPTR.EQ.IDOSTK(1,I)) THEN
                VALUE=IDOSTK(2,I)
                RETURN
            END IF
 100    CONTINUE
        CALL ERRMES('Invalid item expr in DATA statement',-1)
        STATUS=-1
 
        END
C ----------------------------------------------------------------------
C
C       D V I N I T   -   Initialise data-value reader
C
C       D V   -   Read some data values
C
 
        SUBROUTINE DVINIT(NODE,SNODE)
        INTEGER NODE,SNODE,IDTYPE,NITEMS
 
        INTEGER PTR,DTYPE,NVALS,STATUS,P1,P2,COUNT,STNODE
 
        SAVE
 
        INTEGER ZYNTYP,ZYDOWN,ZYNEXT,ZYXGVA,ZYXGDT
        EXTERNAL ZYNTYP,ZYDOWN,ZYNEXT,ZYXGVA,ZYXGDT,ZYXSTB
 
        PTR=NODE
        STNODE=SNODE
        NVALS=0
        RETURN
 
        ENTRY DV(IDTYPE,NITEMS)
 
        COUNT=NITEMS
 
 100    IF (NVALS.EQ.0) THEN
            IF (PTR.EQ.0) THEN
                CALL ERRMES('Insufficient DATA values',-1)
                RETURN
            END IF
            IF (ZYNTYP(PTR).EQ.45) THEN
                P1=ZYDOWN(PTR)
                P2=ZYNEXT(P1)
                CALL EXPR(P1,.TRUE.,0,STATUS)
                CALL EXPR(P2,.TRUE.,0,STATUS)
                IF (STATUS.EQ.-1) RETURN
                NVALS=ZYXGVA(P1)
                IF (NVALS.LT.1) THEN
                    CALL ERRMES('Invalid repetition count',-1)
                    RETURN
                END IF
                DTYPE=ZYXGDT(P2)
            ELSE
                CALL EXPR(PTR,.TRUE.,0,STATUS)
                IF (STATUS.EQ.-1) RETURN
                NVALS=1
                DTYPE=ZYXGDT(PTR)
                P2=PTR
            END IF
        END IF
        IF (DTYPE.NE.IDTYPE) THEN
            CALL ZYXSTB(STNODE,16777216)
            IF ((DTYPE.NE.9 .OR. IDTYPE.NE.1 .AND.
     +          IDTYPE.NE.2 .AND. IDTYPE.NE.3) .AND.
     +          (DTYPE.NE.1 .AND. DTYPE.NE.2 .AND.
     +          DTYPE.NE.5 .AND. DTYPE.NE.15  .AND.
     +          DTYPE.NE.14 .OR.
     +          IDTYPE.NE.1 .AND. IDTYPE.NE.2 .AND.
     +          IDTYPE.NE.5 .AND. IDTYPE.NE.15 .AND.
     +          IDTYPE.NE.14) .AND.
     +          (DTYPE.NE.4 .AND. DTYPE.NE.7 .OR.
     +          IDTYPE.NE.4 .AND. IDTYPE.NE.7)) THEN
               CALL ERRMES('Incompatible types in DATA',-1)
            ELSE IF (DTYPE.EQ.9) THEN
                IF (ZYXGVA(P2).GT.4)
     +              CALL ERRMES('Hollerith constant too long',-1)
            END IF
        END IF
        COUNT=COUNT-NVALS
        IF (COUNT.GE.0) THEN
            NVALS=0
            PTR=ZYNEXT(PTR)
            IF (COUNT.GT.0) GOTO 100
        ELSE
            NVALS=-COUNT
        END IF
        RETURN
 
        ENTRY DVEND
        IF (PTR.NE.0) CALL ERRMES('Too many DATA values',-1)
 
        END
C ----------------------------------------------------------------------
C
C       A R R A Y D   -   Process an array_declarator
C
 
        SUBROUTINE ARRAYD(NODE)
        INTEGER NODE
 
        INTEGER PTR,N,LOW(10),UPPER(10),STATUS,
     +          SYMBOL(8),SYMPTR
        LOGICAL ADJP,INFP,TMPP
 
        INTEGER ZYXGVA,ZYDOWN,ZYNEXT,ZYNTYP,ZIAND
        EXTERNAL ZYXGVA,ZYDOWN,ZYNEXT,ZYNTYP,ZIAND,ZYXSAD
 
        PTR=ZYNEXT(ZYDOWN(NODE))
        SYMPTR=-ZYDOWN(ZYDOWN(NODE))
        ADJP=.FALSE.
        INFP=.FALSE.
        N=1
        STATUS=-2
 100    IF (ZYNTYP(PTR).EQ.23) THEN
            INFP=.TRUE.
            IF (ZYDOWN(PTR).EQ.0) THEN
                LOW(N)=1
            ELSE
                TMPP=.FALSE.
                CALL ARDIM2(ZYDOWN(PTR),LOW(N),TMPP,STATUS)
                IF (STATUS.EQ.-1) RETURN
                IF (TMPP) THEN
                    ADJP=.TRUE.
                    UPPER(N)=LOW(N)-1
                ELSE
                    UPPER(N)=LOW(N)
                END IF
            END IF
        ELSE
            CALL ARDIM(PTR,LOW(N),UPPER(N),ADJP,STATUS)
        END IF
        IF (STATUS.NE.-2) RETURN
        PTR=ZYNEXT(PTR)
        IF (PTR.NE.0) THEN
            N=N+1
            IF (N.LE.10) GOTO 100
            CALL ERRSYM('Too many dimensions in array ',SYMPTR,-1)
        ELSE IF (N.GT.7) THEN
            CALL ERRSYM('Non-standard numb'//'er of dimensions for ',
     +                  SYMPTR,-1)
        END IF
        CALL ZYXSAD(SYMPTR,N,LOW,UPPER,ADJP,INFP)
 
        END
C ----------------------------------------------------------------------
C
C       A R D I M   -   Evaluate array dimensions
C
 
        SUBROUTINE ARDIM(NODE,LOW,HIGH,ADJP,STATUS)
        INTEGER NODE,LOW,HIGH,STATUS
        LOGICAL ADJP
 
        INTEGER TMP,PTR
 
        INTEGER ZYDOWN,ZYNEXT
        EXTERNAL ZYDOWN,ZYNEXT
 
        PTR=ZYDOWN(NODE)
        CALL ARDIM2(PTR,TMP,ADJP,STATUS)
        IF (STATUS.NE.-2) RETURN
        PTR=ZYNEXT(PTR)
        IF (PTR.EQ.0) THEN
            HIGH=TMP
            LOW=1
        ELSE
            LOW=TMP
            CALL ARDIM2(PTR,HIGH,ADJP,STATUS)
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       A R D I M 2   -   Evaluate a single array dimension
C
 
        SUBROUTINE ARDIM2(NODE,LIMIT,ADJP,STATUS)
        INTEGER NODE,LIMIT,STATUS
        LOGICAL ADJP
 
        INTEGER ZIAND,ZYXGTB,ZYXGDT,ZYXGVA
        EXTERNAL ZIAND,ZYXGTB,ZYXGDT,ZYXGVA
 
        CALL EXPR(NODE,.FALSE.,2,STATUS)
        IF (STATUS.EQ.-2) THEN
            IF (ZIAND(ZYXGTB(NODE),2097152).EQ.0) THEN
                ADJP=.TRUE.
                LIMIT=0
            ELSE IF (ZYXGDT(NODE).NE.1) THEN
                CALL ERRMES('Array declarator expr of wrong type',-1)
                STATUS=-1
            ELSE
                LIMIT=ZYXGVA(NODE)
            END IF
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       F M T I D   -   Process a format_identifier
C
 
        SUBROUTINE FMTID(NODE,STATUS)
        INTEGER NODE,STATUS
 
        INTEGER PTR,NTYPE,DTYPE,ARGN,SYMBOL(8)
        LOGICAL BADTYP
 
        LOGICAL ARRAYP,PROCP
 
        INTEGER ZYDOWN,ZYNTYP,ZYXGDT,ZIAND,ZYXGTB
        EXTERNAL ZYDOWN,ZYNTYP,ZYXGDT,ZIAND,ZYXGTB,ZYGTSY
 
        ARRAYP(ARGN)=ZIAND(ZYXGTB(ARGN),4194304).NE.0
        PROCP(ARGN)=ZIAND(ZYXGTB(ARGN),8388608).NE.0
 
        PTR=ZYDOWN(NODE)
        NTYPE=ZYNTYP(PTR)
        IF (NTYPE.NE.116 .AND. NTYPE.NE.17) THEN
            CALL EXPR(PTR,.FALSE.,0,STATUS)
            IF (STATUS.EQ.-1) RETURN
            DTYPE=ZYXGDT(PTR)
            BADTYP=DTYPE.NE.6
            IF (DTYPE.EQ.1 .OR. DTYPE.EQ.2 .OR.
     +          DTYPE.EQ.3 .OR. DTYPE.EQ.12 .OR.
     +          DTYPE.EQ.13) BADTYP=.NOT.ARRAYP(PTR)
            IF (NTYPE.EQ.108 .AND. DTYPE.EQ.1 .AND.
     +          BADTYP) THEN
                CALL ZYGTSY(-ZYDOWN(PTR),SYMBOL)
                BADTYP=ZIAND(SYMBOL(6),16).EQ.0
            END IF
            IF (BADTYP) THEN
                CALL ERRMES('Incorrect type of format expression',-1)
                STATUS=-1
            ELSE IF (PROCP(PTR)) THEN
                CALL ERRMES('Format expression is procedure',-1)
                STATUS=-1
            END IF
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       I O L I S T   -   Process an i/o list
C
 
        SUBROUTINE IOLIST(NODE)
        INTEGER NODE
 
        INTEGER PTR,NTYPE,SYMBOL(8),P2,STATUS,SP,
     +          IDOSTK(2,25),I
 
        INTEGER ZYNEXT,ZYDOWN,ZYNTYP,ZYPREV
        EXTERNAL ZYNEXT,ZYDOWN,ZYPREV,ZYGTSY,ZYNTYP
 
        PTR=NODE
        SP=0
 
 100    NTYPE=ZYNTYP(PTR)
        IF (NTYPE.EQ.108) THEN
            CALL EXPR(PTR,.FALSE.,0,STATUS)
            IF (STATUS.EQ.-1) RETURN
            CALL ZYGTSY(-ZYDOWN(PTR),SYMBOL)
            IF (SYMBOL(1).EQ.5 .AND.
     +          SYMBOL(7).NE.0) THEN
                P2=ZYDOWN(SYMBOL(7))
 200            IF (ZYNTYP(P2).EQ.23) THEN
                    CALL ERRMES('Unsubscripted assumed-size array '//
     +                          'in i-o list',-1)
                    RETURN
                END IF
                P2=ZYNEXT(P2)
                IF (P2.NE.0) GOTO 200
            END IF
        ELSE IF (NTYPE.EQ.71) THEN
            IF (SP.EQ.25)
     +          CALL ERRMES('i/o implied do nesting limit exceeded',
     +                      -1001)
            SP=SP+1
            IDOSTK(1,SP)=ZYNEXT(PTR)
            PTR=ZYDOWN(PTR)
            IDOSTK(2,SP)=-ZYDOWN(ZYDOWN(ZYPREV(PTR)))
            DO 300 I=1,SP-1
                IF (IDOSTK(2,I).EQ.IDOSTK(2,SP)) THEN
                    CALL ERRMES('Duplicate control vars in nested '//
     +                          'implied do loops',-1)
                    RETURN
                END IF
 300        CONTINUE
            GOTO 100
        ELSE
            CALL EXPR(PTR,.FALSE.,0,STATUS)
            IF (STATUS.EQ.-1) RETURN
        END IF
        PTR=ZYNEXT(PTR)
        IF (PTR.NE.0) GOTO 100
        IF (SP.GT.0) THEN
            PTR=IDOSTK(1,SP)
            SP=SP-1
            IF (PTR.NE.0) GOTO 100
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       C I L I S T   -   Process a control-information list
C
 
        SUBROUTINE CILIST(NODE,STATUS)
        INTEGER NODE,STATUS
 
C Note: 'NCII' & 'CIIFIL' must match NCII & CIIFIL in CIITEM, and
C       'UNITCI' must be the number of the UNIT= ciitem.
 
        INTEGER NCII,UNITCI,CIIFIL,CIIREC,CIIEND
        PARAMETER (NCII=21,UNITCI=21,CIIFIL=7,CIIREC=16,CIIEND=4)
 
        INTEGER PTR,NTYPE,P2,DTYPE,I,STYPE
        LOGICAL OCCURS(NCII),FMTOCC,LISDIR,INTFIL
 
        INTEGER ZYNEXT,ZYDOWN,ZYNTYP,ZIAND,ZYXGDT,ZYXGTB,ZYUP
        EXTERNAL ZYNEXT,ZYDOWN,ZYNTYP,ZIAND,ZYXGDT,ZYXGTB,ZYUP,
     +           ZYSABT
 
        LOGICAL PROCP,CONSTP
        INTEGER ARGN
 
        PROCP(ARGN)=ZIAND(ZYXGTB(ARGN),8388608).NE.0
        CONSTP(ARGN)=ZIAND(ZYXGTB(ARGN),2097152).NE.0
 
        PTR=ZYDOWN(NODE)
        DO 100 I=1,NCII
 100        OCCURS(I)=.FALSE.
        FMTOCC=.FALSE.
        LISDIR=.FALSE.
        INTFIL=.FALSE.
        STYPE=ZYNTYP(ZYUP(NODE))
 
 200    NTYPE=ZYNTYP(PTR)
        IF (NTYPE.EQ.122) THEN
            IF (OCCURS(UNITCI)) THEN
                CALL ERRMES('Unit_identifier occurs twice',-1)
                STATUS=-1
                RETURN
            END IF
            OCCURS(UNITCI)=.TRUE.
            IF (ZYNTYP(ZYDOWN(PTR)).NE.17) THEN
                P2=ZYDOWN(PTR)
                CALL EXPR(P2,.FALSE.,0,STATUS)
                IF (STATUS.EQ.-1) RETURN
                DTYPE=ZYXGDT(P2)
                IF (DTYPE.NE.1 .AND. DTYPE.NE.6) THEN
                    CALL ERRMES('Unit-id must be integer/97 string/*',
     +                          -1)
                    STATUS=-1
                    RETURN
                ELSE IF (PROCP(P2)) THEN
                    CALL ERRMES('Unit-identifier is procedure',-1)
                    STATUS=-1
                    RETURN
                ELSE IF (DTYPE.EQ.6) THEN
                    INTFIL=.TRUE.
                    IF (ZYNTYP(P2).NE.108 .AND.
     +                  ZYNTYP(P2).NE.104 .AND.
     +                  ZYNTYP(P2).NE.103 .OR.
     +                  CONSTP(P2)) THEN
                        CALL ERRMES(
     +'Internal file must be variable/array element/substring',-1)
                        STATUS=-1
                        RETURN
                    ELSE IF (STYPE.EQ.65) THEN
C Get symbol pointer (may have to go down two levels, for a substring
C of an array element
                        P2=ZYDOWN(P2)
                        IF (P2.GT.0) P2=ZYDOWN(P2)
                        IF (P2.GT.0) P2=ZYDOWN(P2)
                        IF (P2.GT.0)
     +                      CALL ERRMES('CILIST UNITID ERROR',-1001)
C Say it is modified...
                        CALL ZYSABT(-P2,6,32)
C Also make sure common block (if any) is marked as modified too
                        CALL UPDCOM(-P2)
                    ELSE IF (STYPE.NE.66) THEN
                        CALL ERRMES(
     +'Auxiliary i/o statement specifies an internal file',-1)
                        STATUS=-1
                        RETURN
                    END IF
                END IF
            END IF
        ELSE IF (NTYPE.EQ.123) THEN
            IF (FMTOCC) THEN
                CALL ERRMES('Format-identifier occurs twice',-1)
                STATUS=-1
                RETURN
            END IF
            CALL FMTID(PTR,STATUS)
            IF (STATUS.EQ.-1) RETURN
            LISDIR=ZYNTYP(ZYDOWN(PTR)).EQ.17
            FMTOCC=.TRUE.
        ELSE IF (NTYPE.EQ.69) THEN
            P2=ZYNEXT(ZYDOWN(PTR))
            NTYPE=ZYNTYP(P2)
            IF (NTYPE.NE.17) THEN
                CALL EXPR(P2,.FALSE.,0,STATUS)
                IF (STATUS.EQ.-1) RETURN
            END IF
            CALL CIITEM(PTR,OCCURS,STYPE,STATUS,INTFIL)
            IF (STATUS.EQ.-1) RETURN
        ELSE
            CALL ERRMES('CILIST: TREE IS CORRUPT',-1001)
        END IF
        PTR=ZYNEXT(PTR)
        IF (PTR.GT.0) GOTO 200
        IF ((STYPE.EQ.75 .OR. STYPE.EQ.76 .OR.
     +      STYPE.EQ.77 .OR. STYPE.EQ.65 .OR.
     +      STYPE.EQ.66) .AND. .NOT.OCCURS(UNITCI)) THEN
            CALL ERRMES('No unit-identifier in control-info list',
     +                  -1)
            STATUS=-1
        ELSE IF (STYPE.NE.65.AND.STYPE.NE.66.AND.FMTOCC) THEN
            CALL ERRMES('Format-identifier n'//'ot allowed here',-1)
            STATUS=-1
        ELSE IF (STYPE.EQ.74) THEN
            IF (OCCURS(UNITCI) .AND. OCCURS(CIIFIL)) THEN
                CALL ERRMES('Both UNIT= a'//'nd FILE= in INQUIRE',-1)
                STATUS=-1
            ELSE IF (.NOT.(OCCURS(UNITCI).OR.OCCURS(CIIFIL))) THEN
                CALL ERRMES('Neither UNIT= 124 FILE= in INQUIRE',-1)
                STATUS=-1
            END IF
        ELSE IF (LISDIR.AND.INTFIL) THEN
            CALL ERRMES('List-directed i/o used on internal file',-1)
            STATUS=-1
        ELSE IF (LISDIR.AND.OCCURS(CIIREC)) THEN
            CALL ERRMES('List-directed i/o used on direct-access file',
     +                  -1)
        ELSE IF (OCCURS(CIIREC).AND.OCCURS(CIIEND)) THEN
            CALL ERRMES('Both REC= an'//'d END= occur in c-i list',
     +                  -1)
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       C I I T E M   -   Process a control-info list item
C
 
        SUBROUTINE CIITEM(NODE,OCCURS,STYPE,STATUS,INTFIL)
        INTEGER MAXL,NCII,CIIFIL,CIIERR
        PARAMETER (MAXL=11,NCII=21,CIIFIL=7,CIIERR=5)
 
        INTEGER NODE,STATUS,STYPE
        LOGICAL OCCURS(NCII),INTFIL
 
        CHARACTER*(*) UNKCII
        PARAMETER (UNKCII='Unknown control-info-list item n'//
     +                    'ot checked')
        LOGICAL T,F
        PARAMETER (T=.TRUE.,F=.FALSE.)
 
        INTEGER PTR,TEXT(134),CIINUM,TYPCHK,CIITYP(NCII),I,
     +          NTYPE,DTYPE,SYMBOL(8),SSTYPE(132)
        LOGICAL CIIAST(NCII),CIIVAR(NCII),CIISTY(8,NCII)
        CHARACTER*(MAXL) CIINAM,CIILST(NCII)
 
        SAVE CIILST,CIITYP,CIIAST,CIIVAR,CIISTY,SSTYPE
 
        INTEGER FIND,LENSTR
 
        INTEGER ZYNTYP,ZYDOWN,ZYNEXT,ZYXGDT,ZYXGTB,ZIAND,
     +          LENGTH
        EXTERNAL ZYNTYP,ZYDOWN,ZYNEXT,ZYXGDT,ZYXGTB,ZYGTST,
     +           ZIAND,LENGTH,ZITOF,ZYSABT
 
        LOGICAL BADP,PROCP,CONSTP
 
        BADP(I)=ZIAND(ZYXGTB(I),4194304+8388608).NE.0
        PROCP(I)=ZIAND(ZYXGTB(I),8388608).NE.0
        CONSTP(I)=ZIAND(ZYXGTB(I),2097152).NE.0
 
        DATA SSTYPE(65)/1/,
     +       SSTYPE(66)/2/,
     +       SSTYPE(72)/3/,
     +       SSTYPE(73)/4/,
     +       SSTYPE(74)/5/,
     +       SSTYPE(75)/6/,
     +       SSTYPE(76)/7/,
     +       SSTYPE(77)/8/
 
C Control-information-list item data:
C   Name  Asterisk  Data type  Must be     Ok in stmts:
C         ok?       0=int/char var/arelm?  WRITE,READ,OPEN,CLOSE,
C                                          INQUIRE,BACKSPACE,ENDFILE,
C                                          REWIND
 
        DATA (CIILST(I),CIIAST(I),CIITYP(I),CIIVAR(I),
     +        (CIISTY(J,I),J=1,8),I=1,18)/
     +'ACCESS',F,6,F,F,F,T,F,T,F,F,F,
     +'BLANK',F,6,F,F,F,T,F,T,F,F,F,
     +'DIRECT',F,6,T,F,F,F,F,T,F,F,F,
     +'END',F,10,F,F,T,F,F,F,F,F,F,
     +'ERR',F,10,F,T,T,T,T,T,T,T,T,
     +'EXIST',F,3,T,F,F,F,F,T,F,F,F,
C The parameter CIIFIL *must* be set to the array index for "FILE"
     +'FILE',F,6,F,F,F,T,F,T,F,F,F,
     +'FORM',F,6,F,F,F,T,F,T,F,F,F,
     +'FORMATTED',F,6,T,F,F,F,F,T,F,F,F,
     +'IOSTAT',F,1,T,T,T,T,T,T,T,T,T,
     +'NAME',F,6,T,F,F,F,F,T,F,F,F,
     +'NAMED',F,3,T,F,F,F,F,T,F,F,F,
     +'NEXTREC',F,1,T,F,F,F,F,T,F,F,F,
     +'NUMBER',F,1,T,F,F,F,F,T,F,F,F,
     +'OPENED',F,3,T,F,F,F,F,T,F,F,F,
     +'REC',F,1,F,T,T,F,F,F,F,F,F,
     +'RECL',F,1,F,F,F,T,F,T,F,F,F,
     +'SEQUENTIAL',F,6,T,F,F,F,F,T,F,F,F/
        DATA (CIILST(I),CIIAST(I),CIITYP(I),CIIVAR(I),
     +        (CIISTY(J,I),J=1,8),I=19,NCII)/
     +'STATUS',F,6,F,F,F,T,T,F,F,F,F,
     +'UNFORMATTED',F,6,T,F,F,F,F,T,F,F,F,
     +'UNIT',T,0,F,T,T,T,T,T,T,T,T/
 
        PTR=ZYDOWN(NODE)
        IF (ZYNTYP(PTR).NE.118) CALL ERRMES('CIITEM: TREE CORRUPT',
     +                                         -1001)
        CALL ZYGTST(-ZYDOWN(PTR),TEXT)
        CALL ZTOCAP(TEXT)
        PTR=ZYNEXT(PTR)
        IF (LENGTH(TEXT).GT.MAXL) THEN
            CALL ERRMES(UNKCII,-1002)
            CALL ZCHOUT('         (',2)
            CALL PUTLIN(TEXT,2)
            CALL ZMESS(')',2)
        ELSE
            CALL ZITOF(TEXT,1,MAXL,CIINAM,.FALSE.)
            CIINUM=FIND(CIINAM,CIILST,NCII)
            IF (CIINUM.EQ.0) THEN
                CALL ERRMES(UNKCII//' - '//CIINAM,-1002)
                RETURN
            ELSE IF (OCCURS(CIINUM)) THEN
                CALL ERRMES(CIINAM(:LENSTR(CIINAM))//
     +                      '= duplicated in control-information list',
     +                      -1)
                STATUS=-1
                RETURN
            ELSE IF (.NOT.CIISTY(SSTYPE(STYPE),CIINUM)) THEN
                CALL ERRMES(CIINAM(:LENSTR(CIINAM))//'= n'//
     +                      'ot allowed here',-1)
            END IF
            OCCURS(CIINUM)=.TRUE.
            NTYPE=ZYNTYP(PTR)
            IF (NTYPE.EQ.17) THEN
                IF (.NOT.CIIAST(CIINUM)) THEN
                    CALL ERRMES('Invalid asterisk in ci-item '//CIINAM,
     +                          -1)
                    STATUS=-1
                END IF
            ELSE IF (CIITYP(CIINUM).EQ.0) THEN
                DTYPE=ZYXGDT(PTR)
                IF (DTYPE.NE.1 .AND. DTYPE.NE.6) THEN
                    CALL ERRMES(
     +'Unit-identifier must be integer/character/*',-1)
                ELSE IF (PROCP(PTR)) THEN
                    CALL ERRMES('Unit-identifier is procedure',-1)
                ELSE IF (DTYPE.EQ.6) THEN
                    INTFIL=.TRUE.
                    IF (ZYNTYP(PTR).NE.108 .AND.
     +                  ZYNTYP(PTR).NE.104 .AND.
     +                  ZYNTYP(PTR).NE.103 .OR.
     +                  CONSTP(PTR)) THEN
                        CALL ERRMES(
     +'Internal file must be variable/array element/substring',-1)
                        STATUS=-1
                        RETURN
                    ELSE IF (STYPE.EQ.65) THEN
C Get symbol pointer (may have to go down two levels, for a substring
C of an array element
                        PTR=ZYDOWN(PTR)
                        IF (PTR.GT.0) PTR=ZYDOWN(PTR)
                        IF (PTR.GT.0) PTR=ZYDOWN(PTR)
                        IF (PTR.GT.0)
     +                      CALL ERRMES('CIITEM UNITID ERROR',-1001)
C Say it is modified...
                        CALL ZYSABT(-PTR,6,32)
C Also make sure common block (if any) is marked as modified too
                        CALL UPDCOM(-PTR)
                    ELSE IF (STYPE.NE.66) THEN
                        CALL ERRMES(
     +'Auxiliary i/o statement specifies an internal file',-1)
                        STATUS=-1
                        RETURN
                    END IF
                END IF
            ELSE IF (CIITYP(CIINUM).NE.ZYXGDT(PTR) .OR. BADP(PTR))
     +      THEN
                CALL ERRMES('Incorrect type for '//CIINAM,-1)
                STATUS=-1
            ELSE IF (CIIVAR(CIINUM) .OR. (STYPE.EQ.74 .AND.
     +               CIINUM.NE.CIIFIL .AND. CIINUM.NE.CIIERR)) THEN
                NTYPE=ZYNTYP(PTR)
                IF (NTYPE.NE.108 .AND. NTYPE.NE.104) THEN
                    CALL ERRMES(CIINAM(:LENSTR(CIINAM))//
     +                          ' requires a var/array elt',-1)
                    STATUS=-1
                ELSE
                    IF (NTYPE.EQ.104) PTR=ZYDOWN(PTR)
                    CALL ZYGTSY(-ZYDOWN(PTR),SYMBOL)
                    IF (NTYPE.EQ.108 .AND.
     +                  SYMBOL(1).NE.5 .AND.
     +                  SYMBOL(1).NE.4) THEN
                        CALL ERRMES(CIINAM(:LENSTR(CIINAM))//
     +                              ' requires a var/array elt',-1)
                        STATUS=-1
                    ELSE
                        CALL ZYSABT(-ZYDOWN(PTR),6,
     +                              32)
                    END IF
                END IF
            END IF
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       E X P R   -   Evaluate an expression in the parse tree
C
 
        SUBROUTINE EXPR(NODE,CONST,CHECK,STATUS)
        INTEGER NODE,STATUS,CHECK
        LOGICAL CONST
 
        INTEGER PTR,DEPTH,TMP,SFNAME
        LOGICAL INDATA,INARDC,INSF
 
        INTEGER ZYDOWN,ZYNEXT,ZYUP
        EXTERNAL ZYDOWN,ZYNEXT,ZYUP
 
C
C Setup
C
        PTR=NODE
        INDATA=CHECK.EQ.1
        INARDC=CHECK.EQ.2
        INSF=CHECK.GE.1000
        SFNAME=CHECK/1000
        DEPTH=0
        STATUS=-2
C
C Process a subtree
C
 100    TMP=ZYDOWN(PTR)
        IF (TMP.GT.0) THEN
            PTR=TMP
            DEPTH=DEPTH+1
            GOTO 100
        END IF
C
C Leaf - process this node now!
C
        CALL EVLEAF(PTR,CONST,INDATA,INARDC,INSF,SFNAME,STATUS)
        IF (STATUS.EQ.-1 .OR. DEPTH.EQ.0) RETURN
C
C Process a successor node
C
 200    TMP=ZYNEXT(PTR)
        IF (TMP.GT.0) THEN
            PTR=TMP
            GOTO 100
        END IF
C
C Having processed all things below parent node, we now visit the parent
C (assuming we have one and aren't already at the top)
C
        IF (DEPTH.GT.0) THEN
            DEPTH=DEPTH-1
            PTR=ZYUP(PTR)
            CALL EVNODE(PTR,CONST,INDATA,INSF,SFNAME,STATUS)
            IF (STATUS.EQ.-1) RETURN
        END IF
        IF (DEPTH.GT.0) GOTO 200
 
        END
C ----------------------------------------------------------------------
C
C       E V L E A F   -   Evaluate a leaf node
C
 
        SUBROUTINE EVLEAF(NODE,CONST,INDATA,INARDC,INSF,SFNAME,STATUS)
        INTEGER NODE,STATUS,SFNAME
        LOGICAL CONST,INDATA,INARDC,INSF
 
        INTEGER NTYPE,SYMBOL(8),TEXT(1322),SYMPTR,PTR,
     +          DTYPE,VALUE
        LOGICAL KONST,VSET
 
        INTEGER ZYNTYP,ZYDOWN,ZIAND,LENGTH,ZSCTOI,ZYUP,ZYXGVA,
     +          ZYXGTB,ZYXGDT,ZYCADT
        EXTERNAL ZYNTYP,ZYDOWN,ZYGTSY,ZYGTST,ZIAND,LENGTH,ZSCTOI,ZYUP,
     +           ZYXSDT,ZYXSVA,ZYXSTB,ZYXDST,ZYCADT,
     +           ZYXDSV,ZYXGVA,ZYXGTB,ZYXGDT
 
        NTYPE=ZYNTYP(NODE)
        SYMPTR=-ZYDOWN(NODE)
        VSET=.FALSE.
        KONST=.TRUE.
        IF (NTYPE.EQ.107) THEN
            CALL ZYGTST(SYMPTR,TEXT)
            PTR=1
            VALUE=ZSCTOI(TEXT,PTR)
            VSET=.TRUE.
            DTYPE=1
        ELSE IF (NTYPE.EQ.106) THEN
            DTYPE=1
        ELSE IF (NTYPE.EQ.110) THEN
            DTYPE=2
        ELSE IF (NTYPE.EQ.111) THEN
            DTYPE=5
        ELSE IF (NTYPE.EQ.109) THEN
            DTYPE=3
        ELSE IF (NTYPE.EQ.113) THEN
            DTYPE=9
            CALL ZYGTST(SYMPTR,TEXT)
            CALL ZYXSVA(NODE,LENGTH(TEXT))
        ELSE IF (NTYPE.EQ.114) THEN
            DTYPE=6
            CALL ZYGTST(SYMPTR,TEXT)
            CALL ZYXSVA(NODE,LENGTH(TEXT))
        ELSE IF (NTYPE.EQ.116) THEN
            DTYPE=10
        ELSE IF (NTYPE.EQ.108) THEN
            CALL ZYGTSY(SYMPTR,SYMBOL)
C Set status bit if used in an array declarator
            IF (INARDC) CALL ZYSABT(SYMPTR,6,1048576)
            DTYPE=ZYCADT(SYMBOL(4),SYMBOL(5))
            IF (DTYPE.EQ.0) THEN
                CALL ERRMES('Item has an invalid datatype',-1)
                RETURN
            END IF
C Pretend that subroutine subprograms have no "type", since
C we can't store negative types in the parse tree nodes.
            IF (DTYPE.EQ.-1) DTYPE=0
            IF (SYMBOL(1).EQ.6) THEN
                IF (ZIAND(SYMBOL(6),262144).EQ.0) THEN
                    CALL ERRMES('Parameter used before definition',-1)
                    STATUS=-1
                ELSE IF (SYMBOL(4).EQ.1 .OR.
     +                   SYMBOL(4).EQ.6) THEN
                    VSET=.TRUE.
                    VALUE=SYMBOL(8)
                END IF
            ELSE IF (INDATA) THEN
                NTYPE=ZYNTYP(ZYUP(NODE))
                IF (NTYPE.NE.104 .AND. NTYPE.NE.103 .OR.
     +              ZYDOWN(ZYUP(NODE)).NE.NODE) THEN
                    CALL EVDVAR(SYMPTR,VALUE,STATUS)
                    VSET=STATUS.EQ.-2
                END IF
            ELSE IF (INARDC .AND.
     +          ZIAND(SYMBOL(6),4+1024).EQ.0) THEN
                CALL ERRMES('Var in adj arr expr must be dummy/common',
     +                      -1)
                STATUS=-1
            ELSE IF (CONST .AND. .NOT. INARDC) THEN
                CALL ERRMES('Non-constant name used in constant expr',
     +                      -1)
                STATUS=-1
            ELSE IF (INSF .AND. SFNAME.EQ.SYMPTR) THEN
                CALL ERRMES('Self-recursive statement function',-1)
                STATUS=-1
            ELSE
                IF (SYMBOL(1).EQ.5 .AND.
     +              SYMBOL(7).NE.0)
     +              CALL ZYXSTB(NODE,4194304)
                IF (SYMBOL(1).EQ.7)
     +              CALL ZYXSTB(NODE,8388608)
                IF (SYMBOL(4).EQ.6) THEN
                    VSET=.TRUE.
                    VALUE=SYMBOL(5)
                    IF (VALUE.EQ.0) THEN
                        VALUE=1
                    ELSE IF (VALUE.LT.0) THEN
                        IF (MOD(ZYXGTB(-VALUE),262144).NE.0)
     +                      VALUE=ZYXGVA(-VALUE)
                    END IF
                END IF
                KONST=.FALSE.
            END IF
        ELSE
            CALL ERRMES('Unrecognised leaf node',-1)
            CALL ZCHOUT('   (Node type was: ',2)
            CALL ZPTINT(NTYPE,1,2)
            CALL ZCHOUT(', node nu'//'mber ',2)
            CALL ZPTINT(NODE,1,2)
            CALL ZMESS(')',2)
            STATUS=-1
        END IF
        IF (STATUS.EQ.-2) THEN
            IF (INDATA) THEN
                CALL ZYXDST(NODE,DTYPE)
                IF (VSET) CALL ZYXDSV(NODE,VALUE)
            ELSE
                CALL ZYXSDT(NODE,DTYPE)
                IF (VSET) CALL ZYXSVA(NODE,VALUE)
            END IF
            IF (KONST) CALL ZYXSTB(NODE,2097152)
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       E V N O D E   -   Evaluate a node in an expression
C
 
        SUBROUTINE EVNODE(NODE,CONST,INDATA,INSF,SFNAME,STATUS)
        INTEGER NODE,STATUS,SFNAME
        LOGICAL CONST,INDATA,INSF
 
        INTEGER NTYPE,DN1TYP,DN2TYP,SYMBOL(8),PTR,ARGN,DN1,
     +          NTYPE2,DN2
 
        LOGICAL ARRAYP,CONSTP
 
        INTEGER ZYNTYP,ZYDOWN,ZYNEXT,ZYXGDT,ZYXGTB,ZYUP,ZIAND,
     +         ZYXGVA
        EXTERNAL ZYNTYP,ZYDOWN,ZYNEXT,ZYGTSY,ZYXGDT,ZYUP,ZYXGTB,
     +          ZYXGVA,ZYXDST,ZYXDSV
 
        ARRAYP(ARGN)=ZIAND(ZYXGTB(ARGN),4194304).NE.0
        CONSTP(ARGN)=ZIAND(ZYXGTB(ARGN),2097152).NE.0
 
        NTYPE=ZYNTYP(NODE)
        IF (NTYPE.EQ.119) THEN
            CALL EVFUNC(NODE,CONST,INSF,STATUS)
        ELSE IF (NTYPE.EQ.104) THEN
            IF (CONST .AND. .NOT.INDATA) THEN
                CALL ERRMES('Array element invalid in constant expr',
     +                      -1)
                STATUS=-1
                RETURN
            END IF
            CALL EVAREL(NODE,INDATA,STATUS)
        ELSE IF (NTYPE.EQ.103) THEN
            IF (CONST .AND. .NOT.INDATA) THEN
                CALL ERRMES('Substring invalid in constant expr',-1)
                STATUS=-1
                RETURN
            ELSE IF (INSF) THEN
                PTR=NODE
                CALL ZYGTSY(SFNAME,SYMBOL)
 100            IF (ZYNTYP(PTR).NE.119) THEN
                    PTR=ZYUP(PTR)
                    IF (PTR.NE.SYMBOL(7)) GOTO 100
                    CALL ERRMES('Illegal substring in stmt function',
     +                          -1)
                    STATUS=-1
                END IF
            END IF
            CALL EVSBST(NODE,INDATA,STATUS)
        ELSE IF (NTYPE.EQ.105) THEN
            CALL EVSSP(NODE,INDATA,STATUS)
        ELSE IF (NTYPE.EQ.101) THEN
            CALL ZYXSTB(NODE,ZYXGTB(ZYDOWN(NODE)))
        ELSE IF (NTYPE.EQ.48) THEN
            CALL EVDOSP(NODE,STATUS)
        ELSE IF (NTYPE.EQ.71) THEN
            CALL ERRMES('EVNODE: INTERNAL ERROR: IOIMDL ENCOUNTERED',
     +                  -1001)
        ELSE
            DN1=ZYDOWN(NODE)
            IF (ARRAYP(DN1)) THEN
                CALL ERRMES('Missing subscript',-1)
                STATUS=-1
                RETURN
            END IF
            DN1TYP=ZYXGDT(DN1)
            DN2=ZYNEXT(DN1)
            DN2TYP=0
            IF (DN2.NE.0) THEN
                DN2TYP=ZYXGDT(DN2)
                IF (ARRAYP(DN2)) THEN
                    CALL ERRMES('Missing subscript',-1)
                    STATUS=-1
                    RETURN
                END IF
            END IF
            IF (NTYPE.EQ.91 .OR. NTYPE.EQ.92 .OR. NTYPE.EQ.90 .OR.
     +          NTYPE.EQ.89 .OR. NTYPE.EQ.94 .OR. NTYPE.EQ.93)
     +      THEN
                CALL EVROP(NODE,DN1TYP,DN2TYP,CONST,STATUS)
                IF (CONSTP(DN1).AND.CONSTP(DN2))
     +              CALL ZYXSTB(NODE,2097152)
            ELSE IF (NTYPE.EQ.88) THEN
                CALL ZYXSDT(NODE,3)
                IF (DN1TYP.NE.3 .AND. DN1TYP.NE.12 .AND.
     +              DN1TYP.NE.13) THEN
                    CALL ERRMES('..NOT.. applied to non-logical',-1)
                    STATUS=-1
                ELSE IF (CONSTP(NODE)) THEN
                    CALL ZYXSTB(NODE,2097152)
                END IF
            ELSE IF (NTYPE.EQ.86 .OR. NTYPE.EQ.87 .OR.
     +               NTYPE.EQ.84 .OR. NTYPE.EQ.85) THEN
                CALL EVLOP(NODE,DN1TYP,DN2TYP,CONST,STATUS)
            ELSE IF (NTYPE.EQ.97 .OR. NTYPE.EQ.46) THEN
                IF (DN1TYP.NE.1 .AND. DN1TYP.NE.2
     +              .AND. DN1TYP.NE.5 .AND.
     +              DN1TYP.NE.4 .AND. DN1TYP.NE.7
     +              .AND. DN1TYP.NE.14 .AND.
     +              DN1TYP.NE.15) THEN
                    CALL ERRMES('Invalid types for unary 43/45',
     +                          -1)
                    STATUS=-1
                ELSE
                    IF (INDATA) THEN
                        CALL ZYXDST(NODE,DN1TYP)
                    ELSE
                        CALL ZYXSDT(NODE,DN1TYP)
                    END IF
                    IF (CONSTP(DN1)) THEN
                        CALL ZYXSTB(NODE,2097152)
                        IF (NTYPE.EQ.97 .AND. DN1TYP.EQ.1)
     +                  THEN
                            IF (INDATA) THEN
                                CALL ZYXDSV(NODE,ZYXGVA(DN1))
                            ELSE
                                CALL ZYXSVA(NODE,ZYXGVA(DN1))
                            END IF
                        ELSE IF (DN1TYP.EQ.1) THEN
                            IF (INDATA) THEN
                                CALL ZYXDSV(NODE,-ZYXGVA(DN1))
                            ELSE
                                CALL ZYXSVA(NODE,-ZYXGVA(DN1))
                            END IF
                        END IF
                    END IF
                END IF
            ELSE IF (NTYPE.EQ.95 .OR. NTYPE.EQ.96 .OR.
     +          NTYPE.EQ.98 .OR. NTYPE.EQ.99 .OR.
     +          NTYPE.EQ.100) THEN
                CALL EVA2OP(NODE,DN1,DN2,DN1TYP,DN2TYP,CONST,INDATA,
     +                      STATUS)
            ELSE IF (NTYPE.EQ.70) THEN
                IF (DN1TYP.NE.6 .OR. DN2TYP.GT.6) THEN
                    CALL ERRMES('Concatenation of non-characters',-1)
                    STATUS=-1
                ELSE
                    CALL ZYXSDT(NODE,6)
                    IF (ZYXGVA(DN1).EQ.0 .AND. .NOT.CONSTP(DN1) .OR.
     +                  ZYXGVA(DN2).EQ.0 .AND. .NOT.CONSTP(DN2))
     +                  CALL ERRMES('Concatenation of assumed '//
     +                              'length character string',-1002)
                    IF (ZYXGVA(DN1).LE.0 .AND. ZYXGVA(DN2).LE.0)
     +              THEN
                        CALL ZYXSVA(NODE,-1)
                    ELSE
                        CALL ZYXSVA(NODE,
     +                                  ZYXGVA(DN1)+ZYXGVA(DN2))
                    END IF
                END IF
            ELSE IF (NTYPE.EQ.102) THEN
                NTYPE=ZYNTYP(DN1)
                IF (NTYPE.EQ.46 .OR. NTYPE.EQ.97)
     +              NTYPE=ZYNTYP(ZYDOWN(DN1))
                NTYPE2=ZYNTYP(DN2)
                IF (NTYPE2.EQ.46 .OR. NTYPE2.EQ.97)
     +              NTYPE2=ZYNTYP(ZYDOWN(DN2))
                IF (NTYPE.NE.107 .AND. NTYPE.NE.110 .AND.
     +              NTYPE.NE.111 .OR. NTYPE2.NE.107 .AND.
     +              NTYPE2.NE.110 .AND. NTYPE2.NE.111) THEN
                    CALL ERRMES('Invalid complex constant',-1)
                ELSE IF (DN1TYP.EQ.5 .OR.
     +               DN2TYP.EQ.5) THEN
                    IF (INDATA) THEN
                        CALL ZYXDST(NODE,7)
                    ELSE
                        CALL ZYXSDT(NODE,7)
                    END IF
                ELSE
                    IF (INDATA) THEN
                        CALL ZYXDST(NODE,4)
                    ELSE
                        CALL ZYXSDT(NODE,4)
                    END IF
                END IF
            ELSE
                CALL ERRMES('Unknown operator node',-1)
                STATUS=-1
            END IF
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       E V F U N C   -   Evaluate a function call
C
 
        SUBROUTINE EVFUNC(NODE,CONST,INSF,STATUS)
        INTEGER NODE,STATUS
        LOGICAL CONST,INSF
 
        INTEGER SYMBOL(8),SYMPTR,PTR,DTYPE
 
        INTEGER ZYDOWN,ZIAND,ZYXGVA,ZYXGDT
        EXTERNAL ZYDOWN,ZIAND,ZYGTSY,ZYXSDT,ZYXGDT
 
        PTR=ZYDOWN(NODE)
        DTYPE=ZYXGDT(PTR)
 
        IF (DTYPE.EQ.6) THEN
            CALL ZYXSVA(NODE,ZYXGVA(PTR))
        END IF
 
        IF (CONST) THEN
            CALL ERRMES('Function reference in constant expr',-1)
            STATUS=-1
        ELSE
            CALL ZYGTSY(-ZYDOWN(ZYDOWN(NODE)),SYMBOL)
            IF (SYMBOL(4).EQ.8) THEN
                CALL EVFGEN(NODE,SYMBOL,STATUS)
            ELSE
                CALL ZYXSDT(NODE,SYMBOL(4))
                IF (SYMBOL(1).EQ.8) THEN
                    CALL EVSF(NODE,SYMBOL,STATUS)
                ELSE IF (ZIAND(SYMBOL(6),
     +                         4096+2).NE.0) THEN
                    CALL EVFINT(NODE,SYMBOL,STATUS)
                ELSE
                    CALL EVFEXT(NODE,SYMBOL,INSF,STATUS)
                END IF
            END IF
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       E V R O P   -   Evaluate a relational operator
C
 
        SUBROUTINE EVROP(NODE,DN1TYP,DN2TYP,CONST,STATUS)
        INTEGER NODE,DN1TYP,DN2TYP,STATUS
        LOGICAL CONST
 
        CALL ZYXSDT(NODE,3)
        IF (DN1TYP.NE.1 .AND. DN1TYP.NE.2 .AND.
     +      DN1TYP.NE.5 .AND. DN1TYP.NE.4 .AND.
     +      DN1TYP.NE.6 .AND. DN1TYP.NE.14 .AND.
     +      DN1TYP.NE.15 .AND. DN1TYP.NE.7 .OR.
     +      DN2TYP.NE.1 .AND. DN2TYP.NE.4 .AND.
     +      DN2TYP.NE.5 .AND. DN2TYP.NE.2 .AND.
     +      DN2TYP.NE.6 .AND. DN2TYP.NE.14 .AND.
     +      DN2TYP.NE.15 .AND. DN2TYP.NE.7) THEN
            CALL ERRMES('Invalid types in relational',-1)
            STATUS=-1
        ELSE IF (DN1TYP.EQ.6 .NEQV. DN2TYP.EQ.6) THEN
            CALL ERRMES('Incompatible types in relational',-1)
            STATUS=-1
        ELSE IF ((DN1TYP.EQ.15 .OR. DN2TYP.EQ.15) .AND.
     +           (DN1TYP.EQ.4 .OR. DN1TYP.EQ.7 .OR.
     +           DN2TYP.EQ.4 .OR. DN2TYP.EQ.7))
     +  THEN
            CALL ERRMES('Complex a'//'nd quadruple precision mixed',
     +                  -1)
            STATUS=-1
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       E V A 2 O P   -   Evaluate arithmetic binary operator
C
 
        SUBROUTINE EVA2OP(NODE,DN1,DN2,DN1TYP,DN2TYP,CONST,INDATA,
     +                    STATUS)
        INTEGER NODE,DN1,DN2,DN1TYP,DN2TYP,STATUS
        LOGICAL CONST,INDATA
 
        INTEGER ARITH(-3:15,-3:15),ARGN,
     +          NTYPE
        LOGICAL EVALIT
 
        SAVE ARITH
 
        LOGICAL CONSTP
 
        INTEGER ZYXGVA,ZYXGTB,ZIAND,ZYNTYP
        EXTERNAL ZYXSDT,ZYXSVA,ZYXGVA,ZYXGTB,ZIAND,
     +           ZYNTYP,ZYXDST,ZYXDSV
 
        DATA ARITH(1,1)/1/,
     +       ARITH(1,2)/2/,
     +       ARITH(1,5)/5/,
     +       ARITH(1,4)/4/,
     +       ARITH(1,7)/7/,
     +       ARITH(1,14)/14/,
     +       ARITH(1,15)/15/,
     +       ARITH(2,1)/2/,
     +       ARITH(2,2)/2/,
     +       ARITH(2,5)/5/,
     +       ARITH(2,4)/4/,
     +       ARITH(2,7)/7/,
     +       ARITH(2,14)/2/,
     +       ARITH(2,15)/15/,
     +       ARITH(5,1)/5/,
     +       ARITH(5,2)/5/,
     +       ARITH(5,5)/5/,
     +       ARITH(5,4)/7/,
     +       ARITH(5,7)/7/,
     +       ARITH(5,14)/5/
        DATA ARITH(5,15)/15/,
     +       ARITH(4,1)/4/,
     +       ARITH(4,2)/4/,
     +       ARITH(4,5)/7/,
     +       ARITH(4,4)/4/,
     +       ARITH(4,7)/7/,
     +       ARITH(4,14)/14/,
     +       ARITH(4,15)/0/,
     +       ARITH(7,1)/7/,
     +       ARITH(7,2)/7/,
     +       ARITH(7,5)/7/,
     +       ARITH(7,4)/7/,
     +       ARITH(7,7)/7/,
     +       ARITH(7,14)/7/,
     +       ARITH(7,15)/0/,
     +       ARITH(14,1)/1/,
     +       ARITH(14,2)/2/,
     +       ARITH(14,5)/5/,
     +       ARITH(14,4)/4/,
     +       ARITH(14,7)/7/
        DATA ARITH(14,14)/14/,
     +       ARITH(14,15)/15/,
     +       ARITH(15,1)/15/,
     +       ARITH(15,2)/15/,
     +       ARITH(15,5)/15/,
     +       ARITH(15,4)/0/,
     +       ARITH(15,7)/0/,
     +       ARITH(15,14)/15/,
     +       ARITH(15,15)/15/
 
        CONSTP(ARGN)=ZIAND(ZYXGTB(ARGN),2097152).NE.0
 
        IF (DN1TYP.NE.1 .AND. DN1TYP.NE.2 .AND.
     +      DN1TYP.NE.5 .AND. DN1TYP.NE.4 .AND.
     +      DN1TYP.NE.7 .AND. DN1TYP.NE.14 .AND.
     +      DN1TYP.NE.15 .OR.
     +      DN2TYP.NE.1 .AND. DN2TYP.NE.4 .AND.
     +      DN2TYP.NE.2 .AND. DN2TYP.NE.5 .AND.
     +      DN2TYP.NE.7 .AND. DN2TYP.NE.14 .AND.
     +      DN2TYP.NE.15) THEN
            CALL ERRMES('Invalid types for arithmetic op',-1)
            STATUS=-1
        ELSE IF (ARITH(DN1TYP,DN2TYP).EQ.0) THEN
            CALL ERRMES('Complex a'//'nd quadruple precision mixed',
     +                  -1)
            STATUS=-1
        ELSE
            IF (INDATA) THEN
                CALL ZYXDST(NODE,ARITH(DN1TYP,DN2TYP))
            ELSE
                CALL ZYXSDT(NODE,ARITH(DN1TYP,DN2TYP))
            END IF
            IF (CONSTP(DN1).AND.CONSTP(DN2)) THEN
                CALL ZYXSTB(NODE,2097152)
                NTYPE=ZYNTYP(NODE)
                EVALIT=DN1TYP.EQ.1 .AND. DN2TYP.EQ.1
                IF (EVALIT .AND. .NOT.INDATA) THEN
                  IF (NTYPE.EQ.95) THEN
                      CALL ZYXSVA(NODE,ZYXGVA(DN1)+ZYXGVA(DN2))
                  ELSE IF (NTYPE.EQ.96) THEN
                      CALL ZYXSVA(NODE,ZYXGVA(DN1)-ZYXGVA(DN2))
                  ELSE IF (NTYPE.EQ.98) THEN
                      CALL ZYXSVA(NODE,ZYXGVA(DN1)*ZYXGVA(DN2))
                  ELSE IF (NTYPE.EQ.99) THEN
                      CALL ZYXSVA(NODE,ZYXGVA(DN1)/ZYXGVA(DN2))
                  ELSE IF (NTYPE.EQ.100) THEN
                      CALL ZYXSVA(NODE,ZYXGVA(DN1)**ZYXGVA(DN2))
                  END IF
                ELSE IF (EVALIT) THEN
                  IF (NTYPE.EQ.95) THEN
                      CALL ZYXDSV(NODE,ZYXGVA(DN1)+ZYXGVA(DN2))
                  ELSE IF (NTYPE.EQ.96) THEN
                      CALL ZYXDSV(NODE,ZYXGVA(DN1)-ZYXGVA(DN2))
                  ELSE IF (NTYPE.EQ.98) THEN
                      CALL ZYXDSV(NODE,ZYXGVA(DN1)*ZYXGVA(DN2))
                  ELSE IF (NTYPE.EQ.99) THEN
                      CALL ZYXDSV(NODE,ZYXGVA(DN1)/ZYXGVA(DN2))
                  ELSE IF (NTYPE.EQ.100) THEN
                      CALL ZYXDSV(NODE,ZYXGVA(DN1)**ZYXGVA(DN2))
                  END IF
                END IF
            END IF
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       E V L O P   -   Evaluate a logical operator
C
 
        SUBROUTINE EVLOP(NODE,DN1TYP,DN2TYP,CONST,STATUS)
        INTEGER NODE,DN1TYP,DN2TYP,STATUS
        LOGICAL CONST
 
        INTEGER RESULT(3,3),T1,T2
 
        SAVE RESULT
 
        EXTERNAL ZYXSDT
 
        DATA RESULT/12,13,3,
     +              13,13,3,
     +              3,3,3/
 
        IF (DN1TYP.EQ.12) THEN
            T1=1
        ELSE IF (DN1TYP.EQ.13) THEN
            T1=2
        ELSE IF (DN1TYP.EQ.3) THEN
            T1=3
        ELSE
            CALL ERRMES(
     +'Invalid type of first operand for logical operator',-1)
            STATUS=-1
            RETURN
        END IF
        IF (DN2TYP.EQ.12) THEN
            T2=1
        ELSE IF (DN2TYP.EQ.13) THEN
            T2=2
        ELSE IF (DN2TYP.EQ.3) THEN
            T2=3
        ELSE
            CALL ERRMES(
     +'Invalid type of second operand for logical operator',-1)
            STATUS=-1
            RETURN
        END IF
        CALL ZYXSDT(NODE,RESULT(T1,T2))
 
        END
C ----------------------------------------------------------------------
C
C       E V A R E L   -   Evaluate an array element reference
C
 
        SUBROUTINE EVAREL(NODE,INDATA,STATUS)
        INTEGER NODE,STATUS
        LOGICAL INDATA
 
        INTEGER PTR,SYMBOL(8),SYMPTR,NSUBS,N,LIMITS(2,10),TMP,
     +          ARGN,DTYPE
        LOGICAL ADJP,INFP
 
        LOGICAL CONSTP
 
        LOGICAL ZYXGAD
        INTEGER ZYDOWN,ZYNEXT,ZYXGTB,ZYXGDT,ZIAND,ZYXGVA,
     +          ZYNTYP
        EXTERNAL ZYDOWN,ZYNEXT,ZYGTSY,ZYXGTB,ZYXGDT,
     +           ZYXGAD,ZIAND,ZYXGVA,ZYXSDT,
     +           ZYXSVA,ZYXDST,ZYXDSV,ZYNTYP
 
        CONSTP(ARGN)=ZIAND(ZYXGTB(ARGN),2097152).NE.0
 
        PTR=ZYDOWN(NODE)
        SYMPTR=-ZYDOWN(PTR)
        DTYPE=ZYXGDT(PTR)
        IF (INDATA) THEN
            CALL ZYXDST(NODE,DTYPE)
        ELSE
            CALL ZYXSDT(NODE,DTYPE)
        END IF
        IF (.NOT.ZYXGAD(SYMPTR,NSUBS,LIMITS,ADJP,INFP)) THEN
            CALL ERRMES('Array elt before array declarator',-1)
            STATUS=-1
            RETURN
        END IF
        PTR=ZYNEXT(PTR)
        N=0
 200    N=N+1
        TMP=ZYXGDT(PTR)
        IF (TMP.NE.1 .AND. TMP.NE.2 .AND.
     +      TMP.NE.5 .AND. TMP.NE.14 .AND.
     +      TMP.NE.15) THEN
            CALL ERRMES('Invalid datatype of subscript expression',-1)
            STATUS=-1
            RETURN
        ELSE IF (CONSTP(PTR) .AND. .NOT.ADJP
     +            .AND. .NOT.INFP .AND. TMP.EQ.1 .AND.
     +           LIMITS(1,N).LE.LIMITS(2,N)) THEN
            TMP=ZYXGVA(PTR)
            IF (TMP.LT.LIMITS(1,N).OR.TMP.GT.LIMITS(2,N)) THEN
                CALL ERRMES('Subscript out of range',-1)
                STATUS=-1
                RETURN
            END IF
        END IF
        PTR=ZYNEXT(PTR)
        IF (PTR.GT.0 .AND. N.LT.NSUBS) GOTO 200
        IF (PTR.GT.0) THEN
            CALL ERRMES('Too many subscripts',-1)
            STATUS=-1
        ELSE IF (N.LT.NSUBS) THEN
            CALL ERRMES('Insufficient subscripts',-1)
            STATUS=-1
        ELSE
            CALL ZYGTSY(SYMPTR,SYMBOL)
            IF (SYMBOL(4).EQ.6) THEN
                IF (SYMBOL(5).EQ.0) THEN
                    TMP=1
                ELSE IF (SYMBOL(5).GT.0) THEN
                    TMP=SYMBOL(5)
                ELSE IF (CONSTP(-SYMBOL(5))) THEN
                    TMP=ZYXGVA(-SYMBOL(5))
                ELSE IF (ZYNTYP(-SYMBOL(5)).EQ.17)
     +          THEN
                    TMP=0
                ELSE
                    RETURN
                END IF
                IF (INDATA) THEN
                    CALL ZYXDSV(NODE,TMP)
                    ELSE
                    CALL ZYXSVA(NODE,TMP)
                END IF
            END IF
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       E V S S P   -   Evaluate substring specifier
C
 
        SUBROUTINE EVSSP(NODE,INDATA,STATUS)
        INTEGER NODE,STATUS
        LOGICAL INDATA
 
        INTEGER PTR
 
        INTEGER ZYDOWN,ZYNEXT,ZYXGDT
        EXTERNAL ZYDOWN,ZYNEXT,ZYXGDT,ZYXSDT
 
        IF (INDATA) THEN
            CALL ZYXDST(NODE,11)
        ELSE
            CALL ZYXSDT(NODE,11)
        END IF
        PTR=ZYDOWN(NODE)
        IF (ZYXGDT(PTR).NE.1) THEN
            CALL ERRMES('Invalid substring specifier (1)',-1)
            STATUS=-1
        ELSE IF (ZYXGDT(ZYNEXT(PTR)).NE.1) THEN
            CALL ERRMES('Invalid substring specifier (2)',-1)
            STATUS=-1
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       E V S B S T   -   Evaluate substring reference
C
 
        SUBROUTINE EVSBST(NODE,INDATA,STATUS)
        INTEGER NODE,STATUS
        LOGICAL INDATA
 
        INTEGER PTR,VALUE,VAL1,VAL2,SYMBOL(8),TMPPTR,ARGN
 
        INTEGER ZYDOWN,ZYNEXT,ZYXGDT,ZYXGVA,ZIAND,ZYXGTB,
     +          ZYNTYP
        EXTERNAL ZYDOWN,ZYNEXT,ZYXGDT,ZYXSDT,ZYXSVA,ZYNTYP,
     +           ZYXDST,ZYXDSV,ZYXGVA,ZIAND,ZYXGTB
 
        LOGICAL CONSTP,ARRAYP
 
        CONSTP(ARGN)=ZIAND(ZYXGTB(ARGN),2097152).NE.0
        ARRAYP(ARGN)=ZIAND(ZYXGTB(ARGN),4194304).NE.0
 
        PTR=ZYDOWN(NODE)
        IF (ZYXGDT(PTR).NE.6) THEN
            CALL ERRMES('Substring n'//'ot of a character item',
     +                  -1)
            STATUS=-1
            RETURN
        ELSE IF (ZYXGDT(ZYNEXT(PTR)).NE.11) THEN
            CALL ERRMES('Internal Error: Didn''t expect invalid substr',
     +                  -1001)
        ELSE IF (ARRAYP(PTR)) THEN
            CALL ERRMES(
     +'Missing subscript on array name in substring reference',
     +                      -1)
                RETURN
        ELSE
C Try to work out how long the substring is, and say zero if unknown
            VALUE=0
C First see if we know how long it might be
            TMPPTR=ZYDOWN(PTR)
C .. down an extra level further for substrings of array elements
            IF (TMPPTR.GT.0) TMPPTR=ZYDOWN(TMPPTR)
            CALL ZYGTSY(-TMPPTR,SYMBOL)
            IF (SYMBOL(5).LT.0) THEN
                IF (CONSTP(-SYMBOL(5)))
     +              SYMBOL(5)=ZYXGVA(-SYMBOL(5))
            ELSE IF (SYMBOL(5).EQ.0) THEN
                SYMBOL(5)=1
            END IF
            IF (SYMBOL(5).GT.0) THEN
C We know how long the whole character variable is - now try for the
C substring specifier
                PTR=ZYDOWN(ZYNEXT(PTR))
                IF (CONSTP(PTR)) THEN
                    IF (ZYNTYP(PTR).EQ.106) THEN
                        VAL1=1
                    ELSE
                        VAL1=ZYXGVA(PTR)
                    END IF
                    PTR=ZYNEXT(PTR)
                    IF (CONSTP(PTR)) THEN
                        IF (ZYNTYP(PTR).EQ.106) THEN
                            VAL2=SYMBOL(5)
                        ELSE
                            VAL2=ZYXGVA(PTR)
                        END IF
                        VALUE=VAL2-VAL1+1
                        IF (VALUE.LT.1 .OR. VAL1.LT.1 .OR.
     +                      VAL2.LT.1 .OR.
     +                      VAL1.GT.SYMBOL(5) .OR.
     +                      VAL2.GT.SYMBOL(5)) THEN
                            STATUS=-1
                            CALL ERRMES(
     +                           'Illegal substring specifier value',
     +                           -1)
                            RETURN
                        END IF
                    END IF
                END IF
            END IF
        END IF
        IF (INDATA) THEN
            CALL ZYXDST(NODE,6)
            CALL ZYXDSV(NODE,VALUE)
        ELSE
            CALL ZYXSDT(NODE,6)
            CALL ZYXSVA(NODE,VALUE)
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       E V D O S P   -   Evaluate an implied do spec
C
 
        SUBROUTINE EVDOSP(NODE,STATUS)
        INTEGER NODE,STATUS
 
        INTEGER PTR,DTYPE
 
        INTEGER ZYDOWN,ZYNEXT,ZYXGTB,ZIAND,ZYXGDT
        EXTERNAL ZYDOWN,ZYNEXT,ZYXGTB,ZIAND,ZYXGDT
 
        PTR=ZYDOWN(NODE)
        DTYPE=ZYXGDT(PTR)
        IF (ZIAND(ZYXGTB(PTR),4194304).NE.0) THEN
            CALL ERRMES('Invalid implied DO loop variable',-1)
            STATUS=-1
        ELSE IF (DTYPE.NE.1 .AND. DTYPE.NE.2 .AND.
     +           DTYPE.NE.5 .AND. DTYPE.NE.15 .AND.
     +           DTYPE.NE.14) THEN
            CALL ERRMES('Invalid type of implied DO loop variable',-1)
            STATUS=-1
        ELSE
            PTR=ZYNEXT(PTR)
 100        DTYPE=ZYXGDT(PTR)
            IF (ZIAND(ZYXGTB(PTR),4194304).NE.0) THEN
                CALL ERRMES('Missing subscript in implied DO expr',-1)
                STATUS=-1
                RETURN
            ELSE IF (DTYPE.NE.1 .AND. DTYPE.NE.2 .AND.
     +               DTYPE.NE.5 .AND. DTYPE.NE.15 .AND.
     +               DTYPE.NE.14) THEN
                CALL ERRMES('Invalid type of implied DO loop expr',-1)
                STATUS=-1
                RETURN
            END IF
            PTR=ZYNEXT(PTR)
            IF (PTR.NE.0) GOTO 100
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       E V F I N T   -   Evaluate function: INTRINSIC (and not generic)
C
 
        SUBROUTINE EVFINT(NODE,SYMBOL,STATUS)
        INTEGER NODE,SYMBOL(8),STATUS
 
        LOGICAL T,F
        PARAMETER (T=.TRUE.,F=.FALSE.)
 
        INTEGER NINTS
        PARAMETER (NINTS=67)
 
        CHARACTER*6 INTNAM(NINTS),NAME
        LOGICAL VALID(8,NINTS)
        INTEGER NARGS(NINTS),TYPE(-3:15),J,J2,NAARGS,PTR,
     +          TEXT(134),FUN,ATYPE
 
        SAVE
 
        INTEGER FIND,LENSTR
 
        INTEGER ZYDOWN,ZYNEXT,ZYXGDT,LENGTH,ZYXGTB,ZIAND
        EXTERNAL ZYDOWN,ZYNEXT,ZYXGDT,LENGTH,ZITOF,ZYGTST,
     +           ZYXGTB,ZIAND,ZYXSVA
 
        DATA TYPE(1)/1/,
     +       TYPE(2)/2/,
     +       TYPE(5)/3/,
     +       TYPE(4)/4/,
     +       TYPE(6)/5/,
     +       TYPE(7)/6/,
     +       TYPE(14)/7/,
     +       TYPE(15)/8/,
     +       TYPE(3),TYPE(-2),TYPE(-1),
     +       TYPE(10),TYPE(-3),TYPE(9),
     +       TYPE(11),TYPE(12),TYPE(13)/9*0/
 
C Table:   Name  Nargs  Legal argtypes
C ------                INT REAL DP COMPL CHAR DCMPLX INT*2 REAL*16
 
        DATA (INTNAM(J),NARGS(J),(VALID(J2,J),J2=1,8),J=1,19)/
     +'AIMAG',1,F,F,F,T,F,F,F,F,
     +'ALOG',1,F,T,F,F,F,F,F,F,
     +'ALOG10',1,F,T,F,F,F,F,F,F,
     +'AMAX0',-2,T,F,F,F,F,F,F,F,
     +'AMAX1',-2,F,T,F,F,F,F,F,F,
     +'AMIN0',-2,T,F,F,F,F,F,F,F,
     +'AMIN1',-2,F,T,F,F,F,F,F,F,
     +'AMOD',2,F,T,F,F,F,F,F,F,
     +'CABS',1,F,F,F,T,F,F,F,F,
     +'CCOS',1,F,F,F,T,F,F,F,F,
     +'CDABS',1,F,F,F,F,F,T,F,F,
     +'CEXP',1,F,F,F,T,F,F,F,F,
     +'CHAR',1,T,F,F,F,F,F,F,F,
     +'CLOG',1,F,F,F,T,F,F,F,F,
     +'CMPLX',-1,T,T,T,T,F,T,T,T,
     +'CONJG',1,F,F,F,T,F,F,F,F,
     +'CSIN',1,F,F,F,T,F,F,F,F,
     +'CSQRT',1,F,F,F,T,F,F,F,F,
     +'DABS',1,F,F,T,F,F,F,F,F/
        DATA (INTNAM(J),NARGS(J),(VALID(J2,J),J2=1,8),J=20,38)/
     +'DACOS',1,F,F,T,F,F,F,F,F,
     +'DASIN',1,F,F,T,F,F,F,F,F,
     +'DATAN',1,F,F,T,F,F,F,F,F,
     +'DATAN2',2,F,F,T,F,F,F,F,F,
     +'DBLE',1,T,T,T,T,F,T,T,T,
     +'DCMPLX',-1,T,T,T,T,F,T,T,T,
     +'DCONJG',1,F,F,F,F,F,T,F,F,
     +'DCOS',1,F,F,T,F,F,F,F,F,
     +'DCOSH',1,F,F,T,F,F,F,F,F,
     +'DDIM',2,F,F,T,F,F,F,F,F,
     +'DEXP',1,F,F,T,F,F,F,F,F,
     +'DIMAG',1,F,F,F,F,F,T,F,F,
     +'DINT',1,F,F,T,F,F,F,F,F,
     +'DLOG',1,F,F,T,F,F,F,F,F,
     +'DLOG10',1,F,F,T,F,F,F,F,F,
     +'DMAX1',-2,F,F,T,F,F,F,F,F,
     +'DMIN1',-2,F,F,T,F,F,F,F,F,
     +'DMOD',2,F,F,T,F,F,F,F,F,
     +'DNINT',1,F,F,T,F,F,F,F,F/
        DATA (INTNAM(J),NARGS(J),(VALID(J2,J),J2=1,8),J=39,57)/
     +'DPROD',2,F,T,F,F,F,F,F,F,
     +'DSIGN',2,F,F,T,F,F,F,F,F,
     +'DSIN',1,F,F,T,F,F,F,F,F,
     +'DSINH',1,F,F,T,F,F,F,F,F,
     +'DSQRT',1,F,F,T,F,F,F,F,F,
     +'DTAN',1,F,F,T,F,F,F,F,F,
     +'DTANH',1,F,F,T,F,F,F,F,F,
     +'FLOAT',1,T,F,F,F,F,F,F,F,
     +'IABS',1,T,F,F,F,F,F,F,F,
     +'ICHAR',1,F,F,F,F,T,F,F,F,
     +'IDIM',2,T,F,F,F,F,F,F,F,
     +'IDINT',1,F,F,T,F,F,F,F,F,
     +'IDNINT',1,F,F,T,F,F,F,F,F,
     +'IFIX',1,F,T,F,F,F,F,F,F,
     +'INDEX',2,F,F,F,F,T,F,F,F,
     +'INT',1,T,T,T,T,F,T,T,T,
     +'ISIGN',2,T,F,F,F,F,F,F,F,
     +'LEN',1,F,F,F,F,T,F,F,F,
     +'LGE',2,F,F,F,F,T,F,F,F/
        DATA (INTNAM(J),NARGS(J),(VALID(J2,J),J2=1,8),J=58,NINTS)/
     +'LGT',2,F,F,F,F,T,F,F,F,
     +'LLE',2,F,F,F,F,T,F,F,F,
     +'LLT',2,F,F,F,F,T,F,F,F,
     +'MAX0',-2,T,F,F,F,F,F,F,F,
     +'MAX1',-2,F,T,F,F,F,F,F,F,
     +'MIN0',-2,T,F,F,F,F,F,F,F,
     +'MIN1',-2,F,T,F,F,F,F,F,F,
     +'NINT',1,F,T,T,F,F,F,F,T,
     +'REAL',1,T,T,T,T,F,T,T,T,
     +'SNGL',1,F,F,T,F,F,F,F,F/
 
        CALL ZYGTST(SYMBOL(2),TEXT)
        IF (LENGTH(TEXT).GT.6)
     +      CALL ERRMES('Intrinsic function name too long',-1001)
        CALL ZTOCAP(TEXT)
        CALL ZITOF(TEXT,1,6,NAME,.FALSE.)
        IF (ZIAND(SYMBOL(6),4096).EQ.0) THEN
            CALL ERRMES('Non-standard intrinsic '//NAME(:LENSTR(NAME))//
     +                  ' n'//'ot checked',-1002)
            RETURN
        END IF
        FUN=FIND(NAME,INTNAM,NINTS)
        IF (FUN.EQ.0) THEN
C Not found -- look in the generic intrinsic function list
            CALL EVFGEN(NODE,SYMBOL,STATUS)
            IF (STATUS.NE.-1) THEN
                 CALL ERRMES(
     +'Generic intrinsic function '//NAME(:LENGTH(TEXT))//
     +' explicitly typed',-1002)
            END IF
            RETURN
        END IF
        PTR=ZYDOWN(NODE)
        NAARGS=0
 
 100    PTR=ZYNEXT(PTR)
        IF (PTR.NE.0) THEN
            NAARGS=NAARGS+1
            ATYPE=TYPE(ZYXGDT(PTR))
            IF (ATYPE.EQ.0) THEN
                CALL ERRMES('Invalid argument type to intrinsic '//NAME,
     +                      -1)
                STATUS=-1
                RETURN
            END IF
            IF (.NOT.VALID(ATYPE,FUN)) THEN
                CALL ERRMES('Invalid argument type to intrinsic '//NAME,
     +                      -1)
                STATUS=-1
                RETURN
            END IF
            IF (ZIAND(ZYXGTB(PTR),4194304+8388608).NE.0) THEN
                CALL ERRMES('Argument to intrinsic '//
     +                      NAME(:LENSTR(NAME))//
     +                      ' is array o'//'r procedure',-1)
                STATUS=-1
                RETURN
            END IF
            GOTO 100
        END IF
        IF (NAARGS.NE.NARGS(FUN) .AND. .NOT.
     +      (NARGS(FUN).EQ.-1 .AND. (NAARGS.EQ.1 .OR. NAARGS.EQ.2) .OR.
     +      NARGS(FUN).EQ.-2 .AND. NAARGS.GE.2)) THEN
            CALL ERRMES('Wrong nu'//'mber of arguments to intrinsic '//
     +                  NAME,-1)
            STATUS=-1
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       E V F G E N   -   Evaluate generic intrinsic function reference
C
 
        SUBROUTINE EVFGEN(NODE,SYMBOL,STATUS)
        INTEGER NODE,SYMBOL(8),STATUS
 
        LOGICAL T,F
        INTEGER I,R,D,C,Z,S,Q
        PARAMETER (T=.TRUE.,F=.FALSE.,I=1,R=2,
     +             D=5,C=4,Z=7,
     +             S=14,Q=15)
 
        INTEGER NGENS
        PARAMETER (NGENS=22)
 
        CHARACTER*6 GENNAM(NGENS),NAME
        INTEGER NARGS(NGENS),RESULT(7,NGENS),TYPE(-3:15),J,J2,
     +          TEXT(134),FUN,NAARGS,ARGTYP,PTR
 
        SAVE
 
        INTEGER FIND
 
        INTEGER ZYDOWN,ZYNEXT,ZYXGDT,LENGTH,ZIAND,ZYXGTB
        EXTERNAL ZYDOWN,ZYNEXT,ZYXGDT,LENGTH,ZITOF,ZYXSDT,
     +           ZIAND,ZYXGTB
 
        DATA TYPE(1)/1/,
     +       TYPE(2)/2/,
     +       TYPE(5)/3/,
     +       TYPE(4)/4/,
     +       TYPE(7)/5/,
     +       TYPE(14)/6/,
     +       TYPE(15)/7/,
     +       TYPE(3),TYPE(-2),TYPE(-1),
     +       TYPE(10),TYPE(-3),TYPE(9),
     +       TYPE(11),TYPE(6),TYPE(12),
     +       TYPE(13)/10*0/
 
C Table:   Name  Nargs  Result type by arg type (0=illegal)
C ------                INT REAL DP COMPL DCMPLX INT*2 REAL*16
 
        DATA (GENNAM(J),NARGS(J),(RESULT(J2,J),J2=1,7),J=1,19)/
     +'ABS',1,I,R,D,R,D,S,Q,
     +'ACOS',1,0,R,D,0,0,0,Q,
     +'AINT',1,0,R,D,0,0,0,Q,
     +'ANINT',1,0,R,D,0,0,0,Q,
     +'ASIN',1,0,R,D,0,0,0,Q,
     +'ATAN',1,0,R,D,0,0,0,Q,
     +'ATAN2',2,0,R,D,0,0,0,Q,
     +'COS',1,0,R,D,C,Z,0,Q,
     +'COSH',1,0,R,D,0,0,0,Q,
     +'DIM',2,I,R,D,0,0,0,Q,
     +'EXP',1,0,R,D,C,Z,0,Q,
     +'LOG',1,0,R,D,C,Z,0,Q,
     +'LOG10',1,0,R,D,0,0,0,Q,
     +'MAX',-2,I,R,D,0,0,S,Q,
     +'MIN',-2,I,R,D,0,0,S,Q,
     +'MOD',2,I,R,D,0,0,S,Q,
     +'SIGN',2,I,R,D,0,0,S,Q,
     +'SIN',1,0,R,D,C,Z,0,Q,
     +'SINH',1,0,R,D,0,0,0,Q/
        DATA (GENNAM(J),NARGS(J),(RESULT(J2,J),J2=1,7),J=20,NGENS)/
     +'SQRT',1,0,R,D,C,Z,0,Q,
     +'TAN',1,0,R,D,0,0,0,Q,
     +'TANH',1,0,R,D,0,0,0,Q/
 
        CALL ZYGTST(SYMBOL(2),TEXT)
        IF (LENGTH(TEXT).GT.6)
     +      CALL ERRMES('Intrinsic name too long',-1001)
        CALL ZTOCAP(TEXT)
        CALL ZITOF(TEXT,1,6,NAME,.FALSE.)
        FUN=FIND(NAME,GENNAM,NGENS)
        IF (FUN.EQ.0) THEN
            CALL ERRMES('Couldn''t find intrinsic function "'//
     +                  NAME(:LENGTH(TEXT))//'"',-1)
            STATUS=-1
            RETURN
        END IF
        PTR=ZYDOWN(NODE)
        NAARGS=0
 
 100    PTR=ZYNEXT(PTR)
        IF (PTR.NE.0) THEN
            NAARGS=NAARGS+1
            IF (NAARGS.EQ.1) THEN
                ARGTYP=TYPE(ZYXGDT(PTR))
                IF (ARGTYP.EQ.0) THEN
                    CALL ERRMES('Incorrect argument type to intrinsic',
     +                          -1)
                    STATUS=-1
                    RETURN
                END IF
            ELSE IF (ARGTYP.NE.TYPE(ZYXGDT(PTR))) THEN
                CALL ERRMES('Inconsistent argument types to intrinsic',
     +                      -1)
            END IF
            IF (ZIAND(ZYXGTB(PTR),4194304+8388608).NE.0) THEN
                CALL ERRMES('Intrinsic argument is array/procedure',
     +                      -1)
                STATUS=-1
                RETURN
            END IF
            GOTO 100
        END IF
        IF (NAARGS.NE.NARGS(FUN) .AND. .NOT.
     +      (NARGS(FUN).EQ.-2 .AND. NAARGS.GE.2 .OR.
     +      NARGS(FUN).EQ.-1 .AND. (NAARGS.EQ.1 .OR. NAARGS.EQ.2))) THEN
            CALL ERRMES('Wrong nu'//'mber of arguments to intrinsic',
     +                  -1)
            STATUS=-1
C Cannot have 0 arguments for an intrinsic, esp. a generic one ...
        ELSE IF (RESULT(ARGTYP,FUN).EQ.0) THEN
            CALL ERRMES('Incorrect argument types for intrinsic',-1)
            STATUS=-1
        ELSE IF (SYMBOL(4).EQ.8) THEN
            CALL ZYXSDT(NODE,RESULT(ARGTYP,FUN))
        ELSE IF (RESULT(ARGTYP,FUN).NE.SYMBOL(4)) THEN
            CALL ERRMES('Generic intrinsic function '//
     +                  NAME(:LENGTH(TEXT))//' incorrectly typed',-1)
            STATUS=-1
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       E V F E X T   -   Evaluate an external function reference
C
 
        SUBROUTINE EVFEXT(NODE,SYMBOL,INSF,STATUS)
        INTEGER NODE,SYMBOL(8),STATUS
        LOGICAL INSF
 
        COMMON/DOSTK/DOLVL,DOLBL,DOIDX
        INTEGER DOLVL,DOLBL(25),DOIDX(25)
 
        COMMON/CONTXT/PUN,STMTNO
        INTEGER PUN,STMTNO
 
        INTEGER PTR,TMP,I,ARGNUM
 
        SAVE /CONTXT/,/DOSTK/
 
        INTEGER ZYXPAS,ZYNEXT,ZYDOWN,ZYNTYP
        EXTERNAL ZYXPAS,ZYNEXT,ZYDOWN,ZYNTYP,ZYXSUD
 
        IF (ZYXPAS(NODE,INSF,STMTNO).EQ.-1) THEN
            CALL ERRMES('Inconsistent argument lists',-1)
            STATUS=-1
        ELSE IF (DOLVL.GT.0) THEN
            PTR=ZYNEXT(ZYDOWN(NODE))
            ARGNUM=0
 100        IF (PTR.NE.0) THEN
                TMP=-ZYDOWN(PTR)
                ARGNUM=ARGNUM+1
                DO 200 I=1,DOLVL
                    IF (TMP.EQ.DOIDX(I)) THEN
                        IF (ZYNTYP(PTR).EQ.108) THEN
                            CALL ZYXSUD(-ZYDOWN(ZYDOWN(NODE)),
     +                                        ARGNUM,STMTNO)
                        END IF
                    END IF
 200            CONTINUE
                PTR=ZYNEXT(PTR)
                GOTO 100
            END IF
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       E V S F   -   Evaluate a statement function reference
C
 
        SUBROUTINE EVSF(NODE,SYMBOL,STATUS)
        INTEGER NODE,SYMBOL,STATUS
 
        INTEGER NARGS,ADTYPE(20),ACHLEN(20),PTR,I,ARGN
 
        LOGICAL BADP
 
        INTEGER ZYNEXT,ZYDOWN,ZYXGDT,ZYXGTB,ZIAND
        EXTERNAL ZYXGFA,ZYNEXT,ZYDOWN,ZYXGDT,ZYXGTB,ZIAND
 
        BADP(ARGN)=ZIAND(ZYXGTB(ARGN),4194304+8388608).NE.0
 
        PTR=ZYDOWN(NODE)
        CALL ZYXGFA(-ZYDOWN(PTR),NARGS,ADTYPE,ACHLEN)
        DO 100 I=1,NARGS
            PTR=ZYNEXT(PTR)
            IF (PTR.EQ.0) THEN
                STATUS=-1
                CALL ERRMES('Insufficient arguments to stmt fn',-1)
                RETURN
            ELSE IF (ZYXGDT(PTR).NE.ADTYPE(I)) THEN
                STATUS=-1
                CALL ERRMES('Type mismatch in stmt fn reference',-1)
                RETURN
            ELSE IF (BADP(PTR)) THEN
                STATUS=-1
                CALL ERRMES(
     +'Array o'//'r Procedure name in stmt fn reference',-1)
                RETURN
            END IF
 100    CONTINUE
 
        END
C ----------------------------------------------------------------------
C
C       F I N D   -   Find a name in a sorted table (binary search)
C
 
        INTEGER FUNCTION FIND(NAME,TABLE,TSIZE)
        INTEGER TSIZE
        CHARACTER*(*) NAME,TABLE(TSIZE)
 
        INTEGER I,L,R
 
        INTRINSIC LLE
 
        L=1
        R=TSIZE
 
 100    I=(L+R)/2
        IF (LLE(NAME,TABLE(I))) THEN
            R=I
        ELSE
            L=I+1
        END IF
        IF (L.LT.R) GOTO 100
 
        IF (NAME.EQ.TABLE(L)) THEN
            FIND=L
        ELSE
            FIND=0
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       C O M P A T   -   Say if two datatypes are compatible
C
 
        LOGICAL FUNCTION COMPAT(TYPE1,TYPE2)
        INTEGER TYPE1,TYPE2
 
        IF (TYPE1.EQ.6 .OR. TYPE2.EQ.6 .OR.
     +      TYPE1.EQ.9 .OR. TYPE2.EQ.9) THEN
            COMPAT=TYPE1.EQ.TYPE2
C Check that both sides of a logical assignment are logicals
        ELSE IF (TYPE1.EQ.3 .OR. TYPE1.EQ.12 .OR.
     +           TYPE1.EQ.13) THEN
            IF (TYPE2.EQ.3 .OR. TYPE2.EQ.12 .OR.
     +          TYPE2.EQ.13) THEN
                COMPAT=.TRUE.
            ELSE
                COMPAT=.FALSE.
            ENDIF
        ELSE IF (TYPE2.EQ.3 .OR. TYPE2.EQ.12 .OR.
     +           TYPE2.EQ.13) THEN
            COMPAT=.FALSE.
        ELSE
            COMPAT=.TRUE.
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       G E T S U   -   Get storage unit of item within object
C
 
        INTEGER FUNCTION GETSU(ITEM)
        INTEGER ITEM
 
        INTEGER PTR,STATUS,TMP,ARGN
 
        INTEGER ZYDOWN,ZYNEXT,ZYNTYP,ZYXGVA,ZYXEAE,
     +          ZYXGDT,ZYXSU,ZYXGTB,ZIAND
        EXTERNAL ZYDOWN,ZYNEXT,ZYNTYP,ZYXGVA,ZYXEAE,
     +           ZYXGDT,ZYXSU,ZYXGTB,ZIAND
 
        LOGICAL CONSTP
 
        CONSTP(ARGN)=ZIAND(ZYXGTB(ARGN),2097152).NE.0
 
        GETSU=-1
        STATUS=-2
        CALL EXPR(ITEM,.FALSE.,0,STATUS)
        IF (STATUS.EQ.-1) RETURN
        IF (ZYNTYP(ITEM).EQ.108) THEN
            GETSU=1
            RETURN
        END IF
        IF (ZYNTYP(ITEM).EQ.103) THEN
            PTR=ZYDOWN(ZYNEXT(ZYDOWN(ITEM)))
            IF (ZYNTYP(PTR).EQ.106) THEN
                GETSU=1
            ELSE IF (CONSTP(PTR)) THEN
                GETSU=ZYXGVA(PTR)
            ELSE
                GETSU=-1
                CALL ERRMES('Subscript expression must be constant',
     +                      -1)
                RETURN
            END IF
            PTR=ZYDOWN(ITEM)
        ELSE
            GETSU=1
            PTR=ITEM
        END IF
        IF (ZYNTYP(PTR).EQ.104) THEN
            TMP=ZYXEAE(PTR)
            IF (TMP.EQ.-1) THEN
                CALL ERRMES('Invalid array element reference',-1)
                GETSU=-1
                RETURN
            END IF
            GETSU=TMP*ZYXSU(ZYXGDT(PTR))+GETSU
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       C H K T Y P   -   Check type/byte length compatibility
C
 
        SUBROUTINE CHKTYP(NTYPE,BLEN)
        INTEGER NTYPE,BLEN
 
        IF (NTYPE.EQ.10 .AND. BLEN.NE.4 .AND.
     +      BLEN.NE.2*4 .AND. BLEN.NE.4*4 .OR.
     +      NTYPE.EQ.9 .AND. BLEN.NE.4 .AND.
     +      BLEN*2.NE.4 .OR.
     +      NTYPE.EQ.12 .AND. BLEN.NE.2*4 .AND.
     +      BLEN.NE.4*4 .OR.
     +      NTYPE.EQ.13 .AND. BLEN.NE.4 .AND.
     +      BLEN*2.NE.4 .AND. BLEN*4.NE.4)
     +      CALL ERRMES('Invalid byte length',-1)
 
        END
C ----------------------------------------------------------------------
C
C       S T R L E N   -   Return length of string w/out trailing blanks
C                         (returned length is always at least 1, so it
C                         can be used to select a substring w/out fear).
C
 
        INTEGER FUNCTION LENSTR(STRING)
        CHARACTER*(*) STRING
 
        INTRINSIC LEN
 
        LENSTR=LEN(STRING)
 100    IF (STRING(LENSTR:LENSTR).EQ.' ' .AND. LENSTR.GT.1) THEN
            LENSTR=LENSTR-1
            GOTO 100
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       E R R S Y M   -   Display a symbol error message
C
 
        SUBROUTINE ERRSYM(STRING,SYMPTR,LEVEL)
        CHARACTER*(*) STRING
        INTEGER SYMPTR,LEVEL
 
        CHARACTER*134 MSG
        INTEGER SYMBOL(8),TEXT(134)
 
        INTEGER LENSTR
 
        EXTERNAL ZYGTSY,ZYGTST,ZITOF
 
        CALL ZYGTSY(SYMPTR,SYMBOL)
        CALL ZYGTST(SYMBOL(2),TEXT)
        MSG=STRING
        CALL ZITOF(TEXT,1,134-LEN(STRING),MSG(LEN(STRING)+1:),
     +             .TRUE.)
        CALL ERRMES(MSG(:LENSTR(MSG)),LEVEL)
 
        END
C ----------------------------------------------------------------------
C
C       E R R M E S   -   Display an error message
C
 
        SUBROUTINE ERRMES(STRING,LEVEL)
        CHARACTER*(*) STRING
        INTEGER LEVEL
 
        COMMON/ERRORC/NERROR,NWARN
        INTEGER NERROR,NWARN
 
        COMMON/CONTXT/PUN,STMTNO
        INTEGER PUN,STMTNO
 
        COMMON/PUNAMC/PUNAME
        CHARACTER*6 PUNAME
 
        SAVE /ERRORC/,/CONTXT/,/PUNAMC/
 
        EXTERNAL ZCHOUT,ZPTINT,PUTCH,ERROR
 
        IF (LEVEL.EQ.-1) THEN
            CALL ZCHOUT('Error: ',2)
            NERROR=NERROR+1
        ELSE IF (LEVEL.EQ.-1002) THEN
            CALL ZCHOUT('Warning: ',2)
            NWARN=NWARN+1
        ELSE IF (LEVEL.EQ.-1001) THEN
            CALL ZCHOUT('Fatal Error: ',2)
        ELSE IF (LEVEL.EQ.-2) THEN
            CALL ZCHOUT('Info: ',2)
        END IF
        CALL ZCHOUT(STRING,2)
        IF (STMTNO.GT.0) THEN
            CALL ZCHOUT(' at statement ',2)
            CALL ZPTINT(STMTNO,1,2)
        END IF
        CALL ZCHOUT(' in '//PUNAME,2)
        CALL PUTCH(10,2)
        IF (LEVEL.EQ.-1001)
     +      CALL ERROR('FATAL ERROR - ANALYSIS ABORTED')
 
        END
C ----------------------------------------------------------------------
C
C       U P D C O M   -   If variable is in common, mark the common as
C                         updated (this is for internal files)
C
 
        SUBROUTINE UPDCOM(VARPTR)
        INTEGER VARPTR
 
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        INTEGER COMPTR
 
        INTEGER ZIOR
        EXTERNAL ZIOR
 
        COMPTR=SYMATR(SYMBOL(8,VARPTR)+1)
 
        IF (COMPTR.NE.0) THEN
            SYMATR(SYMBOL(7,COMPTR))=
     +          ZIOR(SYMATR(SYMBOL(7,COMPTR)),32)
        END IF
 
        END
